malacology
/
staden-lg
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
staden-lg/src/staden/dbsyscommon.f~

5836 lines
172 KiB
FortranFixed
Raw Permalink Blame History

C DBSYS ROUTINES COMMON TO PRE AND POST .RD PROGRAMS
C 8-4-92 altered gtconc, summer,summar,dsplay
C 6-4-92 bug fix in autocn: i did not copy the correct elements
C for some cases where a better alignment was found: i was
C copying from jlefts instead of ilefts, jlc and jsense.
C Further sap routines are in dbsysold.f (pre .rd) and dbsysnew.f (post)
C the split was made by rs 23-1-91
C 4-5-90 Change to getreg to allow escape
C 4-5-90 addition of graphics routines and changes to menus
C 9-5-90 added default gel reading: many changes
C 17-5-90 Fixed 3 bugs in screen editing: 1) rightjustified names
C caused problems; 2) beginnings of sequences starting at far
C right of lines where not seen; 3) lines with no numbers at
C the end of a contig (i.e. with <10 chars) were flagged
C as errors. Changes to ltype for 1, linlen for 2, dsplay for 3
C 9-7-90 removed menu routines
C 20-8-90 changed gelid to add / to reading name because xsap did
C not return the INFLAG = 3 for the default
C 23-8-90 Changes to dbauto and autocn to deal with failures better
C Plus addition of calls to BUSY
C 9-11-90 Replaced call to radio with call to radion
C 19-11-90 Changed max match length in dbauto to maxglm+1 (was 50)
C 25-11-90 Very important bug fix in tpchek. Old versions could
C duplicate bits of working versions.
C 28-11-90 Modified slider to receive maxpg and maxpc and to allow exactly
C the requested number of matches at each end of the two
C sequences.
C Added two new options to dbauto: all gels to new contigs, all
C gels to contig 1; plus resurrected forbidding joins to allow
C sequences to be entered only into the contig the overlap best.
C Changed autocn to sort overlaps into order based on % mismatch
C (previously it saved the best two in any order)
C Minor change to dbstar
C 3-1-91 Discovered bug in dbopen: incorrect call to getint when the
C database is very old and needs values for the current format
C 21-1-91 GELID allowed illegal gel numbers to be returned! Fixed it.
C 22-1-91 Modified autocn, adism4,adism3 to give more info about
C overlaps, and to allow 10 overlaps. Modified dbopen to
C return version number, ditto dbstar
C 23-1-91 Split into dbsyscommon, dbsysold, dbsysnew
C 26-2-91 Improved overflow check in padcop
C 28-7-91 added extra parameter to quality calc: mxgood is the maximum
C reading length in which we have confidence, so only add this
C many chars from the start of each reading. Also changed the
C quality calc to make it the same as the consensus one. Made
C all characters have nonzero score and made lowercase = 100
C 21-8-91 Changed arrfil to arrfim which does not display comments
C 22-8-91 Added routine to find contig line number given left gel (CLINNO)
C 8-11-91 Added fmt4lp which is used by "find internal joins" and would
C be useful elsewhere as a replacement for fmt4ln
C 18-11-91 New routine GETLN2 with returns gel number specified
C 27-2-92 Added use of ctonum to cfgel to deal with gel and vector
C being different case.
C 2-3-92 set FILNAM = ' ' for some calls to openf1
C SUBROUTINE TO READ CHARACTER DATA FROM IDEV, REMOVE SPACES, FILL
C ARRAY AND RETURN NUMBER OF ELEMENTS USED. ANY LINES STARTING WITH
C A ; ARE TREATED AS COMMENTS
SUBROUTINE ARRFIM(IDEV,SEQNCE,J,KBOUT)
C 14-8-91 Added err= option to read, and set length to 0 if error found
C AUTHOR: RODGER STADEN
CHARACTER TEMP(80),SEQNCE(J)
CHARACTER SPACE,ENDCHR,TITCHR
SAVE ENDCHR,SPACE,TITCHR
DATA ENDCHR/'@'/
DATA SPACE/' '/
DATA TITCHR/';'/
IDMX=J
J=0
1 CONTINUE
READ(IDEV,1001,END=30,ERR=40)TEMP
1001 FORMAT(80A1)
IF(TEMP(1).EQ.TITCHR)THEN
C WRITE(KBOUT,1003)(TEMP(K),K=2,80)
C1003 FORMAT(' ',79A1)
GO TO 1
END IF
10 CONTINUE
DO 20 I=1,80
IF(TEMP(I).NE.SPACE)THEN
IF(TEMP(I).EQ.ENDCHR)RETURN
IF(J.EQ.IDMX)THEN
WRITE(KBOUT,1002)IDMX
1002 FORMAT(
+ ' Too much data. Maximum possible',
+ ' =',I6,', input stopped there')
RETURN
END IF
J=J+1
SEQNCE(J)=TEMP(I)
END IF
20 CONTINUE
GO TO 1
30 CONTINUE
RETURN
40 CONTINUE
CALL ERROM(KBOUT,'Error reading file')
J = 0
END
C ABEDIN
C
C ROUTINE TO EDIT THE DB USING A PADDED SEQ
C HAVE AN ARRAY SEQC2 LENGTH IDC OF PADDED SECTION OF CONTIG LINCON
C THE LEFT END OF THE PADDED CONTIG STARTS AT X
C THERE ARE ITOTPC PADS TO MAKE
C
SUBROUTINE ABEDIN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+GEL,LINCON,X,SEQC2,ITOTPC,IDC,IDBSIZ,KBOUT,IDEVR,IDEVW,
+MAXGEL)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ),X,POSN
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
CHARACTER SEQC2(IDC),GEL(MAXGEL),P
SAVE P
DATA P/','/
C
C POINT TO CONTIG
POSN=X-1
C POINT TO SEQC2
IAT=0
C COUNT PADS DONE
IDONE=0
C LOOP FOR ALL SEQC2
DO 100 J=1,IDC
POSN=POSN+1
IAT=IAT+1
IPAD=0
C IS THIS A PADDING CHAR?
IF(SEQC2(IAT).NE.P)GO TO 100
50 CONTINUE
C COUNT PADS
IPAD=IPAD+1
IAT=IAT+1
IF(SEQC2(IAT).EQ.P)GO TO 50
C END OF THIS STRETCH OF PADS,DO INSERT
C HAVE IPAD INSERTS TO MAKE AT POSN
CALL PADCON(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+GEL,LINCON,POSN,IPAD,IDBSIZ,IDEVR,IDEVW,MAXGEL,KBOUT)
C MOVE POINTER TO CONTIG
POSN=POSN+IPAD
C COUNT PADS DONE
IDONE=IDONE+IPAD
C ANY MORE TO DO?
IF(IDONE.EQ.ITOTPC)GO TO 101
100 CONTINUE
C ERROR SHOULD HAVE DONE ALL PADS
WRITE(KBOUT,1000)
1000 FORMAT(' Problem: some pads were not done!')
101 CONTINUE
END
C ACONS
SUBROUTINE ACONS(RELPG,LNGTHG,LNBR,RNBR,NAMPRO,NGELS,NCONTS,
+SEQ1,IDIM1,GEL,IDBSIZ,ISTART,ANS,LLINO,LREG,RREG,TEMP,
+CHRSIZ,MAXGL2,KBOUT,
+IDEVW,IFAIL,MAXGEL,IDM,PERCD)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ),ANS,CHRSIZ
INTEGER LREG,RREG,X,Y,TEMP(CHRSIZ,MAXGL2)
CHARACTER SEQ1(IDIM1)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
CHARACTER GEL(MAXGEL)
CHARACTER NAMPRO*(*)
C WRITE(KBOUT,1000)
C1000 FORMAT(' CALCULATING A CONSENSUS')
C
C
C
CALL BUSY(KBOUT)
IFAIL=0
IF(ANS.EQ.1)GO TO 150
N=IDBSIZ-NCONTS
DO 110 I=N,IDBSIZ-1
J=LNBR(I)
X=1
Y=RELPG(I)
ISTART=ISTART+1
IF((ISTART+19+Y).GT.IDIM1)THEN
WRITE(KBOUT,1009)IDIM1
1009 FORMAT(
+' Database maximum consensus length(',I6,') exceeded',/,
+' calculation aborted')
IFAIL=1
RETURN
END IF
CALL ADDTIT(SEQ1(ISTART),NAMPRO,J,ISTART)
CALL SUMMER(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
1SEQ1(ISTART),Y,GEL,X,Y,J,IDBSIZ,TEMP,CHRSIZ,MAXGL2,IDEVW,MAXGEL,
+IDM,PERCD)
ISTART=ISTART+Y-1
110 CONTINUE
RETURN
C SELECTED CONTIGS ONLY
150 CONTINUE
ISTART=ISTART+1
IDIM11=RREG-LREG+1
IF((ISTART+19+IDIM11).GT.IDIM1)THEN
WRITE(KBOUT,1009)IDIM1
IFAIL=1
RETURN
END IF
CALL ADDTIT(SEQ1(ISTART),NAMPRO,LLINO,ISTART)
C
C
CALL SUMMER(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
1SEQ1(ISTART),IDIM11,GEL,LREG,RREG,LLINO,IDBSIZ,TEMP,
+CHRSIZ,MAXGL2,
2IDEVW,MAXGEL,IDM,PERCD)
ISTART=ISTART+IDIM11-1
C
RETURN
END
SUBROUTINE ADDTIT(SEQ1,NAMPRO,NGELS,IDIM1)
C AUTHOR: RODGER STADEN
CHARACTER SEQ1(20),NAMPRO*(*)
CHARACTER NUMS(10)
SAVE NUMS
DATA NUMS/'0','1','2','3','4','5','6','7','8','9'/
CALL FILLC(SEQ1(2),18,'-')
SEQ1(1) = '<'
SEQ1(20) = '>'
IEND = INDEX(NAMPRO,'.')
N=NGELS
K=IEND+3
DO 10 J=1,3
N=MOD(N,10)+1
NAMPRO(K:K)=NUMS(N)
N=NGELS/(10**J)
K=K-1
10 CONTINUE
K = 18-IEND
K=K/2
DO 20 I=1,IEND+3
SEQ1(K)=NAMPRO(I:I)
K=K+1
20 CONTINUE
IDIM1=IDIM1+20
RETURN
END
SUBROUTINE ADISM1(SEQ,IDIM,GEL,IDIMG,SAVPS,SAVPG,IDSAV,
+CENDS,NENDS,IDCEND,MAXCON,ILEFTS,ILC,IPOSC,IPOSG,ISENSE,
+LLINO,IMATC,
+ISTRAN,KBOUT,MATCH)
C AUTHOR: RODGER STADEN
C NEW PARMS
INTEGER ILEFTS(2),ILC(2),IPOSC(2),IPOSG(2),ISENSE(2),LLINO(2)
CCCCCCCCCCCC
INTEGER CENDS(MAXCON)
INTEGER NENDS(MAXCON)
INTEGER SAVPS(IDSAV),SAVPG(IDSAV)
CHARACTER SEQ(IDIM),GEL(IDIMG),MATCH(IDIMG)
C
C EDITED 07-02-83 TO ALLOW FOR CASE WHERE A GEL OVERLAPS ADJACENT
C CONTIGS WITHIN THE LENGTH OF THE GEL. USE PARM THAT CONTAINS
C THE POSITION OF THE LEFT END OF THE NEXT CONTIG. SET TO VERY HIGH
C VALUE TO START
NEXTC=IDIM+1
C SORT THE MATCHING WORDS INTO ASCENDING ORDER ON POSITION IN SEQ
CALL BUB2AS(SAVPS,SAVPG,IDSAV)
C LOOK FOR SEPERATE MATCHES
LEND=IDIMG-SAVPG(1)+SAVPS(1)
C COUNT NUMBER OF MATCHING CONTIGS
IMATC=IMATC+1
CALL ADISM2(SEQ,IDIM,GEL,IDIMG,SAVPS(1),
1SAVPG(1),CENDS,NENDS,IDCEND,MAXCON,
1ILEFTS,ILC,IPOSC,IPOSG,ISENSE,LLINO,IMATC,ISTRAN,NEXTC,KBOUT,
2MATCH)
DO 10 I=2,IDSAV
IF((SAVPS(I).LT.LEND).AND.(SAVPS(I).LT.NEXTC))GO TO 10
C NEW MATCH, DISPLAY IT
C COUNT NUMBER OF MATCHING CONTIGS
IMATC=IMATC+1
CALL ADISM2(SEQ,IDIM,GEL,IDIMG,SAVPS(I),
1SAVPG(I),CENDS,NENDS,IDCEND,MAXCON,
1ILEFTS,ILC,IPOSC,IPOSG,ISENSE,LLINO,IMATC,ISTRAN,NEXTC,KBOUT,
2MATCH)
C
C RESET LEND
LEND=IDIMG-SAVPG(I)+SAVPS(I)
10 CONTINUE
RETURN
END
C
C ADISM2
C ROUTINE TO DISPLAY MATCHES
SUBROUTINE ADISM2(SEQ,IDIM1,GEL,IDIMG,ISAVPS,SAVPG,CENDS,NENDS,
+IDCEND,MAXCON,ILEFTS,ILC,IPOSC,IPOSG,ISENSE,LLINO,IMATC,ISTRAN,
+NEXTC,KBOUT,MATCH)
C AUTHOR: RODGER STADEN
C NEW PARMS
INTEGER ILEFTS(2),ILC(2),IPOSC(2),IPOSG(2),ISENSE(2),LLINO(2)
CCCCCCCCCCC
CHARACTER SEQ(IDIM1),GEL(IDIMG),MATCH(IDIMG)
INTEGER SAVPS,SAVPG,CENDS(MAXCON)
INTEGER NENDS(MAXCON)
C EDITED 07-02-83 FOR NEXTC. SEE ADISM1.
C DELETE 20 FROM END OF CONSENSUS MATCH
SAVPS=ISAVPS-19
C FIND CONTIG CONSENSUS ENDS
JJ=1
DO 5 J=2,IDCEND
IF(SAVPS.GT.CENDS(J))GO TO 5
C GONE PAST SO LAST IS THE ONE
JJ=J-1
GO TO 6
5 CONTINUE
JJ=IDCEND
6 CONTINUE
C SUBTRACT 1 FROM END
SAVPS=SAVPS-1
C LENGTH FROM MATCH TO LEFT OF CONTIG
LCL=SAVPS-CENDS(JJ)
C RIGHT
LCR=CENDS(JJ+1)-ISAVPS-1
C LEFT GEL
LGL=SAVPG-1
LGR=IDIMG-SAVPG
C NEED MIN OF EACH PAIR
LL=MIN(LCL,LGL)
LR=MIN(LCR,LGR)
C LENGTH OF OVERLAP
LM=LR+LL+1
C DISPLAY STARTS
ICL=ISAVPS-LL
IGL=SAVPG-LL
WRITE(KBOUT,1000)NENDS(JJ)
1000 FORMAT(' Match found with contig number =',I6)
CALL SQMTCH(SEQ(ICL),GEL(IGL),MATCH,LM)
L=ICL-CENDS(JJ)-19
CALL FMT4LN(SEQ(ICL),GEL(IGL),MATCH,LM,L,IGL,KBOUT)
C UPDATE END OF NEXT CONTIG
NEXTC=CENDS(JJ+1)+20
IF(IMATC.GT.2)RETURN
ILEFTS(IMATC)=CENDS(JJ)+20
ILC(IMATC)=LCL+LCR+1
IPOSC(IMATC)=LCL+1
IPOSG(IMATC)=SAVPG
LLINO(IMATC)=NENDS(JJ)
ISENSE(IMATC)=1
IF(ISTRAN.EQ.2)ISENSE(IMATC)=-1
RETURN
END
SUBROUTINE ADISM3(ISAVPS,SAVPG,CENDS,NENDS,
+IDCEND,MAXCON,ILEFTS,ILC,IPOSC,IPOSG,ISENSE,LLINO,IMATC,ISTRAN,
+NEXTC,MAXC,KBOUT)
C AUTHOR: RODGER STADEN
INTEGER ILEFTS(MAXC),ILC(MAXC),IPOSC(MAXC),IPOSG(MAXC)
INTEGER ISENSE(MAXC),LLINO(MAXC)
INTEGER SAVPS,SAVPG,CENDS(MAXCON)
INTEGER NENDS(MAXCON)
SAVPS=ISAVPS-19
JJ=1
DO 5 J=2,IDCEND
IF(SAVPS.GT.CENDS(J))GO TO 5
JJ=J-1
GO TO 6
5 CONTINUE
JJ=IDCEND
6 CONTINUE
SAVPS=SAVPS-1
LCL=SAVPS-CENDS(JJ)
LCR=CENDS(JJ+1)-ISAVPS-1
NEXTC=CENDS(JJ+1)+20
IF(IMATC.LE.MAXC) THEN
ILEFTS(IMATC)=CENDS(JJ)+20
ILC(IMATC)=LCL+LCR+1
IPOSC(IMATC)=LCL+1
IPOSG(IMATC)=SAVPG
LLINO(IMATC)=NENDS(JJ)
ISENSE(IMATC)=1
IF(ISTRAN.EQ.2)ISENSE(IMATC)=-1
WRITE(KBOUT,1000)LLINO(IMATC),IPOSC(IMATC),ISTRAN,
+ IPOSG(IMATC)
1000 FORMAT
+ (' Contig',I5,' position',I6,' matches strand',I2,
+ ' at position',I5)
ELSE
CALL ERROM(KBOUT,'Warning: too many overlaps')
END IF
END
SUBROUTINE ADISM4(IDIM,IDIMG,SAVPS,SAVPG,IDSAV,
+CENDS,NENDS,IDCEND,MAXCON,ILEFTS,ILC,IPOSC,IPOSG,ISENSE,
+LLINO,IMATC,ISTRAN,MAXC,KBOUT)
C AUTHOR: RODGER STADEN
INTEGER ILEFTS(MAXC),ILC(MAXC),IPOSC(MAXC),IPOSG(MAXC)
INTEGER ISENSE(MAXC),LLINO(MAXC)
INTEGER CENDS(MAXCON)
INTEGER NENDS(MAXCON)
INTEGER SAVPS(IDSAV),SAVPG(IDSAV)
NEXTC=IDIM+1
CALL BUB2AS(SAVPS,SAVPG,IDSAV)
IMATC=IMATC+1
CALL ADISM3(SAVPS(1),SAVPG(1),CENDS,NENDS,IDCEND,MAXCON,
+ ILEFTS,ILC,IPOSC,IPOSG,ISENSE,LLINO,IMATC,ISTRAN,NEXTC,MAXC,
+ KBOUT)
LEND=IDIMG-SAVPG(1)+SAVPS(1)
DO 10 I=2,IDSAV
IF((SAVPS(I).LT.LEND).AND.(SAVPS(I).LT.NEXTC))GO TO 10
IMATC=IMATC+1
CALL ADISM3(SAVPS(I),SAVPG(I),CENDS,NENDS,IDCEND,MAXCON,
+ ILEFTS,ILC,IPOSC,IPOSG,ISENSE,LLINO,IMATC,ISTRAN,NEXTC,MAXC,
+ KBOUT)
LEND=IDIMG-SAVPG(I)+SAVPS(I)
10 CONTINUE
IMATC = MIN(IMATC,MAXC)
RETURN
END
SUBROUTINE AEDIT(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,LGEL,NCONT,
+GEL,MAXGEL,CON,IDC,IDEVW,IDEVR,LREG,RREG,KBOUT)
INTEGER RELPG(IDBSIZ),LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
CHARACTER GEL(MAXGEL),CON(IDC)
INTEGER RREG,PC,PCA,PG
NG = LGEL
PG = RELPG(NG)
PC = LREG
NTT = 0
NCT = 0
NDT = 0
10 CONTINUE
C WRITE(*,*)'GEL',NG
CALL READW(IDEVW,NG,GEL,MAXGEL)
LG = ABS(LNGTHG(NG))
IF(PC.LT.LREG) PC = LREG
PCA = PC - LREG + 1
IG = PC - PG + 1
LC = MIN(LG,RREG-PC+1)
C WRITE(*,*)'PC,PG,IG,LG,PCA,LC',PC,PG,IG,LG,PCA,LC
CALL ET(GEL(IG),LG,CON(PCA),LC,NE)
NTT = NTT + NE
CALL EC(GEL(IG),LG,CON(PCA),LC,NE)
NCT = NCT + NE
CALL ED(GEL(IG),LG,CON(PCA),LC,ND)
NDT = NDT + ND
CALL WRITEW(IDEVW,NG,GEL,MAXGEL)
IF(ND.GT.0) THEN
K = LNGTHG(NG)
LNGTHG(NG) = ABS(LNGTHG(NG)) - ND
LNGTHG(NG) = SIGN(LNGTHG(NG),K)
CALL WRITER(IDEVR,NG,RELPG(NG),LNGTHG(NG),LNBR(NG),RNBR(NG))
END IF
IF(RNBR(NG).NE.0) THEN
NG = RNBR(NG)
PG = RELPG(NG)
PC = PG
IF(PG.LE.RREG) GO TO 10
END IF
CALL EDR(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,LGEL,NCONT,
+CON,IDC,IDEVW,IDEVR,LREG)
WRITE(KBOUT,1000)NTT
1000 FORMAT(' Number of transpositions=',I6)
WRITE(KBOUT,1001)NCT
1001 FORMAT(' Number of changes =',I6)
WRITE(KBOUT,1002)NDT
1002 FORMAT(' Number of deletions =',I6)
END
C AJOIN2
C COMPLETES JOIN AND RETURNS LENGTH OF NEW CONTIG IN LLINOR
SUBROUTINE AJOIN2(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
+RELX,LLINOL,LLINOR,LNCONL,LNCONR,IDEVR)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ)
INTEGER LNBR(IDBSIZ),RNBR(IDBSIZ),LNGTHG(IDBSIZ)
INTEGER RELX
C RELX IS THE POSITION OF THE JOINT
C LLINOL IS THE LEFT GEL NUMBER OF THE LEFT CONTIG
C LLINOR IS THE LEFT GEL OF THE RIGHT CONTIG
C LNCONL IS THE LEFT CONTIG LINE NUMBER
C LNCONR IS THE RIGHT CONTIG LINE NUMBER
C
C ADJUST ALL RELATIVE POSITIONS IN RIGHT CONTIG
N=LLINOR
RELPG(N)=RELX
50 CONTINUE
IF(RNBR(N).EQ.0)GO TO 60
N=RNBR(N)
RELPG(N)=RELPG(N)+RELX-1
GO TO 50
60 CONTINUE
C
C FIX UP NEW GEL LINE FOR OLD LEFT OF RIGHT CONTIG
LNBR(LLINOR)=RNBR(LNCONL)
C FIX UP RIGHT GEL OF LEFT CONTIG
N=RNBR(LNCONL)
RNBR(N)=LLINOR
C MERGE WILL SORT OUT THE CORRECT NEIGHBOURS
C
CALL MERGE(RELPG,LNGTHG,LNBR,RNBR,LNCONL,IDBSIZ)
C MERGE DOES NOT WRITE TO DISK
N=LNBR(LNCONL)
65 CONTINUE
C WRITE(IDEVR,REC=N)RELPG(N),LNGTHG(N),LNBR(N),RNBR(N)
CALL WRITER(IDEVR,N,RELPG(N),LNGTHG(N),LNBR(N),RNBR(N))
N=RNBR(N)
IF(N.NE.0)GO TO 65
C CONTIG LINES
X=RELPG(LNCONR)+RELX-1
C LENGTH MAY NOT HAVE INCREASED!
IF(X.GT.RELPG(LNCONL))RELPG(LNCONL)=X
C SAVE LENGTH OF NEW CONTIG
RELX=RELPG(LNCONL)
C WRITE(IDEVR,REC=LNCONL)RELPG(LNCONL),LNGTHG(LNCONL),LNBR(LNCONL),
C 1RNBR(LNCONL)
CALL WRITER(IDEVR,LNCONL,RELPG(LNCONL),LNGTHG(LNCONL),
+LNBR(LNCONL),RNBR(LNCONL))
C
C NOW MOVE ALL DATA DOWN TO DELETE OLD RIGHT END
N=IDBSIZ-NCONTS
M=LNCONR-N
IF(M.EQ.0)GO TO 80
K=LNCONR
J=LNCONR-1
DO 70 I=1,M
RELPG(K)=RELPG(J)
LNGTHG(K)=LNGTHG(J)
LNBR(K)=LNBR(J)
RNBR(K)=RNBR(J)
C WRITE(IDEVR,REC=K)RELPG(K),LNGTHG(K),LNBR(K),RNBR(K)
CALL WRITER(IDEVR,K,RELPG(K),LNGTHG(K),LNBR(K),RNBR(K))
K=K-1
J=J-1
70 CONTINUE
80 CONTINUE
NCONTS=NCONTS-1
C WRITE(IDEVR,REC=IDBSIZ)NGELS,NCONTS
CALL WRITER(IDEVR,IDBSIZ,NGELS,NCONTS,NGELS,NCONTS)
90 CONTINUE
RETURN
END
C SUBROUTINE AJOIN3
SUBROUTINE AJOIN3(RELPG,IDBSIZ,LINCON,ITYPE,ISENSE,JOINT,IDIM22,
+KLASS,IOVER,KBOUT,PL,PR)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ),LINCON(2),IDIM22(2)
INTEGER ITYPE(2),ISENSE(2),JOINT(2),PL(2),PR(2)
C
C CALC POSITIONS OF CONTIGS RELATIVE TO FIXED GEL
DO 20 I=1,2
C R+
IF((ITYPE(I).NE.-1).OR.(ISENSE(I).NE.1))GO TO 11
PL(I)=-1*JOINT(I)+2
PR(I)=PL(I)+RELPG(LINCON(I))-1
GO TO 20
C L+
11 CONTINUE
IF((ITYPE(I).NE.1).OR.(ISENSE(I).NE.1))GO TO 12
PL(I)=JOINT(I)
PR(I)=PL(I)+RELPG(LINCON(I))-1
GO TO 20
C R-
12 CONTINUE
IF((ITYPE(I).NE.-1).OR.(ISENSE(I).NE.-1))GO TO 13
PR(I)=JOINT(I)+IDIM22(I)-1
PL(I)=PR(I)-RELPG(LINCON(I))+1
GO TO 20
C L-
13 CONTINUE
PR(I)=IDIM22(I)-JOINT(I)+1
PL(I)=PR(I)-RELPG(LINCON(I))+1
20 CONTINUE
C LENGTH OF OVERLAP
IOVER=MIN(PR(1),PR(2))-MAX(PL(1),PL(2))+1
WRITE(KBOUT,1002)IOVER
1002 FORMAT(' Length of overlap between the contigs=',I6)
C
C CLASS NUMBER 1-16
KLASS=1
IF(ITYPE(1).EQ.1)KLASS=KLASS+8
IF(ISENSE(1).EQ.-1)KLASS=KLASS+4
IF(ITYPE(2).EQ.1)KLASS=KLASS+2
IF(ISENSE(2).EQ.-1)KLASS=KLASS+1
C WRITE(KBOUT,1001)KLASS
C1001 FORMAT(' CLASS OF JOIN=',I6)
RETURN
END
C ALINE
C
C ROUTINE TO LINE UP 2 SEQS.
C IT SLIDES,REMOVES OVERLAPPING MATCHES,
C SORTS MATCHES INTO ASCENDING ORDER, THEN DOES DOES A TOPOLOGICAL
C CHECK, AND THEN PRODUCES 2 LINED UP SEQS WITH PADDING CHARS
C VARIABLES
C SEQ1 CONSENSUS
C SEQ2 GEL ORIGINAL IN CORRECT ORIENTATION
C SEQG2 ALIGNED GEL
C SEQC2 ALIGNED CONSENSUS
C SEQ3 SAVED GEL RAW DATA
C ISAV1,2,3 STORE MATCHES AND POSITIONS
C IDSAV NUMBER ISAV'S
C IDC LENGTH OF INPUT SEQ1
C IDIM2 LENGTH OF INPUT SEQ2
C IDOUT LENGTH OF OUTPUT ALIGNED SEQ1
C IDIM2 LENGTH OF SEQ2 ON OUTPUT AFTER ALIGNMENT
C MINSLI MIN MATCH FOR SLIDING
C IFAIL FLAG TO SHOW IF ALIGNMENT FAILED DUE TO TOO
C MANY MISMATCHES OR TOPOLIGICAL CHECK OR TOO MANY OR TOO MANY
C PADDING CHARS. 1=FAIL,0=PASS
C
SUBROUTINE ALINE(SEQ1,SEQ2,SEQG2,SEQC2,ISAV1,ISAV2,ISAV3,
+IDSAV,IDC,IDIM2,IDOUT,IC1,IG1,MINSLI,JOINT,
+ITOTPC,ITOTPG,IFAIL,ITYPE,MAXPC,MAXPG,PERMAX,KBOUT,SEQ3,MAXGEL,
+PERCM)
C AUTHOR: RODGER STADEN
CHARACTER SEQ1(IDC),SEQ2(IDIM2),SEQG2(IDOUT),SEQC2(IDOUT)
CHARACTER SEQ3(MAXGEL)
INTEGER ISAV1(IDSAV),ISAV2(IDSAV),ISAV3(IDSAV)
MINSLT=MINSLI
C SAVE SEQ2
CALL SQCOPY(SEQ2,SEQ3,IDIM2)
CALL MSTLKL(SEQ3,IDIM2)
IFAIL=1
C FIND MATCHES
IPP=IDSAV
CALL SLIDER(SEQ1,IDC,SEQ3,IDIM2,IC1,IG1,MAXPG,MAXPC,MINSLT,
+ISAV1,ISAV2,ISAV3,IPP)
IF(IPP.GT.IDSAV)RETURN
IF(IPP.LT.1)RETURN
CALL REMOVL(ISAV2,ISAV3,ISAV1,IPP)
CALL BUB3AS(ISAV2,ISAV3,ISAV1,IPP)
C DO TOPOLOGICAL CHECK
CALL TPCHEK(ISAV2,ISAV3,ISAV1,IPP)
IFAIL=0
CALL LINEUP(SEQ2,SEQ1,SEQG2,SEQC2,IDC,IDIM2,IDOUT,ISAV3,ISAV2,
+ISAV1,IPP,ITOTPC,ITOTPG,JOINT,ITYPE,KBOUT,MAXGEL,IFAIL)
IF(IFAIL.NE.0)RETURN
C IDIM2 IS NOW LENGTH OF ALIGNED GEL
WRITE(KBOUT,1052)ITOTPC,ITOTPG
1052 FORMAT(' Padding in contig= ',I4,' and in gel= ',I4)
CALL DALIGN(SEQC2,SEQG2,SEQ3,MAXGEL,IDOUT,IDIM2,JOINT,
+ITYPE,PERCM,KBOUT,IFAIL)
C ARE ALL CHECKS OK?
IF(ITOTPC.GT.MAXPC)IFAIL=1
IF(ITOTPG.GT.MAXPG)IFAIL=1
IF(PERCM.GT.PERMAX)IFAIL=1
END
SUBROUTINE ARCSER(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+IDBSIZ,KBIN,KBOUT,IDEVN,
+IHELPS,IHELPE,FILEH,IDEVH)
CHARACTER FILEH*(*)
C AUTHOR: RODGER STADEN
C SEARCHES FOR ARCHIVE NAMES
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
CHARACTER NAME1*10,NAME2*10
10 CONTINUE
L = 0
CALL GTSTR('Archive name',' ',NAME1,L,KBOUT,KBIN,INFLAG)
IF(L.EQ.0) RETURN
CALL CCASE(NAME1,1)
IF(INFLAG.EQ.2) RETURN
IF(INFLAG.EQ.3) RETURN
IF(NAME1(1:1).EQ.' ') RETURN
IF(INFLAG.EQ.1) THEN
CALL HELP2(IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
GO TO 10
END IF
DO 100 I=1,NGELS
CALL READN(IDEVN,I,NAME2)
IF(NAME1.EQ.NAME2) THEN
WRITE(KBOUT,1003)NAME2,I,RELPG(I),LNGTHG(I),LNBR(I),RNBR(I)
1003 FORMAT(' ',A,2X,I4,2X,I6,2X,I6,2X,I6,2X,I6/)
GO TO 10
END IF
100 CONTINUE
WRITE(KBOUT,1004)NAME1
1004 FORMAT(' ',A,' Not in database')
GO TO 10
END
SUBROUTINE AUTOCN(SEQ1,IDIM,GEL,IDIMG,ILEFTS,ILC,IPOSC,
+IPOSG,ISENSE,LLINO,IMATC,IFCOMP,MINMAT,POSNS,WORDP,WORDN,
+CONST,LENGTH,LPOWRC,KBOUT,MATCH,MAXGEL,MAXGLM,GELCOP,GELN,
+SAVPS,SAVPG,SAVL,MAXSAV,CENDS,NENDS,MAXCON,
+SEQG2,SEQC2,SEQ4,IDOUT,IDIM22,ITOTPG,ITOTPC,JOINT,IFAIL,
+ITYPE,MAXPC,MAXPG,PERMAX,MINSLI,SEQG3,SEQC3,KFAIL)
C AUTHOR: RODGER STADEN
C changed 29-11-90 to make first in list of alignments the best
INTEGER ILEFTS(2),ILC(2),IPOSC(2),IPOSG(2),ISENSE(2),LLINO(2)
INTEGER POSNS(IDIM),GELN(MAXGLM),WORDP(LPOWRC),SAVPS(MAXSAV)
INTEGER SAVPG(MAXSAV),SAVL(MAXSAV)
INTEGER WORDN(LPOWRC)
CHARACTER GELCOP(MAXGLM),MATCH(MAXGLM)
INTEGER CENDS(MAXCON),NENDS(MAXCON)
INTEGER CONST(LENGTH)
CHARACTER SEQ1(IDIM),GEL(MAXGLM)
C
CHARACTER SEQG2(MAXGLM,2),SEQC2(MAXGLM,2),SEQ4(MAXGLM)
INTEGER IDOUT(2),IDIM22(2),ITOTPG(2),ITOTPC(2),JOINT(2)
INTEGER IFAIL(2),ITYPE(2)
PARAMETER (MAXC = 10)
CHARACTER SEQG3(MAXGLM),SEQC3(MAXGLM)
INTEGER JLEFTS(MAXC),JLC(MAXC),JPOSC(MAXC),JPOSG(MAXC)
INTEGER JSENSE(MAXC),JLLINO(MAXC)
REAL PERMIS(2)
IFAIL(1) = 1
IFAIL(2) = 1
KFAIL = 0
C 23-8-90 Need to deal with failures in a better way. Problem is
C case where overlaps are found but fail to align. In future
C signal them with new variable KFAIL which will be nonzero
C if any alignment fails.
C 29-11-90 Changed sorting of overlaps so that the best is first in the
C list returned to caller.
C SAVE GEL
CALL SQCOPY(GEL,GELCOP,IDIMG)
C COUNT NUMBER OF CONTIGS THAT MATCH
IMATC=0
IDCEND=MAXCON
CALL BUSY(KBOUT)
CALL FNDCON(SEQ1,IDIM,CENDS,NENDS,IDCEND,MAXCON,KBOUT)
CALL ENCO(SEQ1,IDIM,POSNS,CONST,LENGTH)
CALL ENCONA(POSNS,IDIM,WORDP,WORDN,LPOWRC,LENGTH)
1 CONTINUE
ISTRAN=1
2 CONTINUE
CALL MSTLKL(GEL,IDIMG)
CALL ENCO(GEL,IDIMG,GELN,CONST,LENGTH)
IDSAV=MAXSAV
CALL CFGEL(GELN,IDIMG,POSNS,IDIM,WORDP,WORDN,LENGTH,LPOWRC,
+SAVPG,SAVPS,SAVL,
+IDSAV,SEQ1,GEL,MINMAT,IFCOMP,KBOUT)
IF(IFCOMP.NE.0)RETURN
IF(IDSAV.NE.0)THEN
CALL ADISM4(IDIM,IDIMG,SAVPS,SAVPG,IDSAV,CENDS,NENDS,
+ IDCEND,MAXCON,JLEFTS,JLC,JPOSC,JPOSG,JSENSE,JLLINO,
+ IMATC,ISTRAN,MAXC,KBOUT)
END IF
ISTRAN=ISTRAN+1
IF(ISTRAN.EQ.2) THEN
CALL SQCOPY(GELCOP,GEL,IDIMG)
CALL SQREV(GEL,IDIMG)
CALL SQCOM(GEL,IDIMG)
GO TO 2
END IF
CALL SQCOPY(GELCOP,GEL,IDIMG)
KSENSE = 0
WRITE(KBOUT,*)'Total matches found',IMATC
IF(IMATC.EQ.0) THEN
IFAIL(1) = 0
RETURN
END IF
JMATC = 0
DO 100 I = 1,IMATC
IF(JSENSE(I).EQ.-1) THEN
IF(KSENSE.EQ.0) THEN
CALL SQREV(GEL,IDIMG)
CALL SQCOM(GEL,IDIMG)
KSENSE = 1
END IF
END IF
JDIM22 = IDIMG
JDOUT = MAXGEL
IDSAV = MAXSAV
WRITE(KBOUT,*)'Trying to align with contig',JLLINO(I)
CALL ALINE(SEQ1(JLEFTS(I)),GEL,SEQG3,SEQC3,
+ SAVPS,SAVPG,SAVL,IDSAV,JLC(I),JDIM22,JDOUT,
+ JPOSC(I),JPOSG(I),MINSLI,JJOINT,JTOTPC,JTOTPG,
+ JFAIL,JTYPE,MAXPC,MAXPG,PERMAX,KBOUT,SEQ4,MAXGEL,PERMS)
IF(JFAIL.EQ.0) THEN
JMATC = JMATC + 1
IF(JMATC.EQ.1) THEN
C Save in elements 1
CALL COPYM(JLEFTS(I),ILEFTS(1),JLC(I),ILC(1),
+ JPOSC(I),IPOSC(1),JSENSE(I),ISENSE(1),
+ JLLINO(I),LLINO(1),JJOINT,JOINT(1),JTOTPC,
+ ITOTPC(1),JTOTPG,ITOTPG(1),JTYPE,ITYPE(1),
+ JDOUT,IDOUT(1),JDIM22,IDIM22(1),
+ SEQG3,SEQG2(1,1),SEQC3,SEQC2(1,1),
+ PERMS,PERMIS(1))
IFAIL(1) = 0
ELSE IF(JMATC.EQ.2) THEN
IF(PERMS.LT.PERMIS(1)) THEN
C Better match so save in elements 1, so copy 1 to 2 first
CALL COPYM(ILEFTS(1),ILEFTS(2),ILC(1),ILC(2),
+ IPOSC(1),IPOSC(2),ISENSE(1),ISENSE(2),
+ LLINO(1),LLINO(2),JOINT(1),JOINT(2),ITOTPC(1),
+ ITOTPC(2),ITOTPG(1),ITOTPG(2),ITYPE(1),ITYPE(2),
+ IDOUT(1),IDOUT(2),IDIM22(1),IDIM22(2),
+ SEQG2(1,1),SEQG2(1,2),SEQC2(1,1),SEQC2(1,2),
+ PERMIS(1),PERMIS(2))
IFAIL(2) = 0
C Now save in 1
CALL COPYM(JLEFTS(I),ILEFTS(1),JLC(I),ILC(1),
+ JPOSC(I),IPOSC(1),JSENSE(I),ISENSE(1),
+ JLLINO(I),LLINO(1),JJOINT,JOINT(1),JTOTPC,
+ ITOTPC(1),JTOTPG,ITOTPG(1),JTYPE,ITYPE(1),
+ JDOUT,IDOUT(1),JDIM22,IDIM22(1),
+ SEQG3,SEQG2(1,1),SEQC3,SEQC2(1,1),
+ PERMS,PERMIS(1))
ELSE
C Save in element 2
CALL COPYM(JLEFTS(I),ILEFTS(2),JLC(I),ILC(2),
+ JPOSC(I),IPOSC(2),JSENSE(I),ISENSE(2),
+ JLLINO(I),LLINO(2),JJOINT,JOINT(2),JTOTPC,
+ ITOTPC(2),JTOTPG,ITOTPG(2),JTYPE,ITYPE(2),
+ JDOUT,IDOUT(2),JDIM22,IDIM22(2),
+ SEQG3,SEQG2(1,2),SEQC3,SEQC2(1,2),
+ PERMS,PERMIS(2))
IFAIL(2) = 0
END IF
ELSE
IF(PERMS.LT.PERMIS(1)) THEN
C Better match so save in elements 1, so copy 1 to 2 first
CALL COPYM(ILEFTS(1),ILEFTS(2),ILC(1),ILC(2),
+ IPOSC(1),IPOSC(2),ISENSE(1),ISENSE(2),
+ LLINO(1),LLINO(2),JOINT(1),JOINT(2),ITOTPC(1),
+ ITOTPC(2),ITOTPG(1),ITOTPG(2),ITYPE(1),ITYPE(2),
+ IDOUT(1),IDOUT(2),IDIM22(1),IDIM22(2),
+ SEQG2(1,1),SEQG2(1,2),SEQC2(1,1),SEQC2(1,2),
+ PERMIS(1),PERMIS(2))
IFAIL(2) = 0
C Now save in 1
CALL COPYM(JLEFTS(I),ILEFTS(1),JLC(I),ILC(1),
+ JPOSC(I),IPOSC(1),JSENSE(I),ISENSE(1),
+ JLLINO(I),LLINO(1),JJOINT,JOINT(1),JTOTPC,
+ ITOTPC(1),JTOTPG,ITOTPG(1),JTYPE,ITYPE(1),
+ JDOUT,IDOUT(1),JDIM22,IDIM22(1),
+ SEQG3,SEQG2(1,1),SEQC3,SEQC2(1,1),
+ PERMS,PERMIS(1))
ELSE IF(PERMS.LT.PERMIS(2)) THEN
C Save in element 2
CALL COPYM(JLEFTS(I),ILEFTS(2),JLC(I),ILC(2),
+ JPOSC(I),IPOSC(2),JSENSE(I),ISENSE(2),
+ JLLINO(I),LLINO(2),JJOINT,JOINT(2),JTOTPC,
+ ITOTPC(2),JTOTPG,ITOTPG(2),JTYPE,ITYPE(2),
+ JDOUT,IDOUT(2),JDIM22,IDIM22(2),
+ SEQG3,SEQG2(1,2),SEQC3,SEQC2(1,2),
+ PERMS,PERMIS(2))
END IF
END IF
ELSE
KFAIL = 1
END IF
100 CONTINUE
IMATC = MIN(2,JMATC)
END
SUBROUTINE BATIN(SEQ,MAXSEQ,KBIN,KBOUT,IDEV1,IDEV2,IDEV3,
+FILNAM,IHELPS,IHELPE,HELPF,IDEVH)
C AUTHOR RODGER STADEN
CHARACTER SEQ(MAXSEQ)
CHARACTER FILNAM*(*),HELPF*(*)
CHARACTER BASE(4),BKEY(4)
SAVE BASE,BKEY
DATA BASE/'A','C','G','T'/
DATA BKEY/'N','M',',','.'/
CALL CBASE(BASE,BKEY,IOK,ICBASE,
+KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH)
IF(IOK.NE.0) RETURN
FILNAM = ' '
CALL OPENF1(IDEV1,FILNAM,1,IOK,KBIN,KBOUT,
+'File of file names',
+IHELPS,IHELPE,HELPF,IDEVH)
IF(IOK.NE.0) RETURN
NGELS=0
10 CONTINUE
IDIM=MAXSEQ
WRITE(KBOUT,1003)
1003 FORMAT(' Type data on lines of < 80 characters, finish with @'/)
CALL ARRFIM(KBIN,SEQ,IDIM,KBOUT)
IF(IDIM.GT.0)THEN
FILNAM = ' '
CALL OPENF1(IDEV2,FILNAM,1,IOK,KBIN,KBOUT,
+ 'File name for gel reading',
+ IHELPS,IHELPE,HELPF,IDEVH)
IF(IOK.EQ.0) THEN
IF(ICBASE.EQ.0) THEN
CALL CCASEA(SEQ,IDIM,2)
DO 5 J = 1,4
CALL SUBS(SEQ,IDIM,BKEY(J),BASE(J))
5 CONTINUE
END IF
CALL CCASEA(SEQ,IDIM,1)
CALL FMTDKN(IDEV2,SEQ,IDIM)
CLOSE(UNIT=IDEV2)
NGELS=NGELS+1
WRITE(IDEV1,1002)FILNAM
1002 FORMAT( A)
END IF
END IF
CALL YESNO(IANS,'Type in another gel reading',
+IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
IF(IANS.EQ.0) GO TO 10
CALL YESNO(IANS,'List gel readings',
+IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
IF(IANS.EQ.0) THEN
REWIND IDEV1
DO 50 I=1,NGELS
IDIM=MAXSEQ
READ(IDEV1,1002)FILNAM
CALL OPENRS(IDEV2,FILNAM,IOK,LRECL,2)
IF(IOK.NE.0)THEN
WRITE(KBOUT,*)' Error opening file'
GO TO 50
END IF
WRITE(IDEV3,1007)FILNAM
1007 FORMAT(' ',A)
CALL ARRFIM(IDEV2,SEQ,IDIM,KBOUT)
IF(IDIM.GT.0)CALL FMTDB(SEQ,IDIM,1,IDIM,60,IDEV3)
CLOSE(UNIT=IDEV2)
50 CONTINUE
END IF
CLOSE(UNIT=IDEV1)
WRITE(KBOUT,*)'Number of gel readings entered',NGELS
END
C BEDIN
C
C SUBROUTINE TO BED A NEW GEL INTO THE DATABASE. IT DISPLAYS
C THE JOIN AND ALLOWS CHANGES TO IT, THEN IT ALLOWS EDITING OF
C THE NEW GEL USING EDITG OR THE GELS IN THE DATABASE USING
C DBEDIT. ANY CHANGES CAN BE DISPLAYED USING DSPLAY. THIS SUBROUTINE
C RETURNS NOPT TO TELL OF THE OUTCOME OF ITS USE:3=OK,1=REJOIN,4=GIVE UP
C ON INPUT NOPT=2 MEANS LEFT END OVERLAP
SUBROUTINE BEDIN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+GEL,GEL2,LINCON,LLINO,NOPT,X,IDBSIZ,IDEV,KBIN,KBOUT,
+IDEVR,IDEVW,IDEVN,LINLEN,PERCD,
+HELPS1,HELPE1,HELPS2,HELPE2,FILEH,IDEVH,MAXGEL,IDM)
CHARACTER FILEH*(*)
INTEGER HELPS1,HELPE1,HELPS2,HELPE2
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ),ANS
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
CHARACTER GEL(MAXGEL)
CHARACTER GEL2(MAXGEL)
PARAMETER (MAXPRM = 32)
CHARACTER PROMPT(5)*(MAXPRM)
INTEGER LREG,RIGHTM
INTEGER X,RREG
C SAVE NOPT FOR LEFT END OR RIGHT JOIN
NTYPE=NOPT
LREG=X
IF(NTYPE .EQ.2)LREG=1
RREG=LREG+49
IF(RREG.GT.RELPG(LINCON))RREG=RELPG(LINCON)
I1=1
IF(NTYPE.EQ.2)I1=X
I2=I1+49
IF(I2.GT.ABS(LNGTHG(NGELS)))I2=ABS(LNGTHG(NGELS))
CALL DSPLAY(RELPG,LNGTHG,LNBR,RNBR,GEL2,
+LLINO,LINCON,LREG,RREG,GEL,I1,I2,2,LLINOR,IDBSIZ,IDEV,
+KBOUT,IDEVW,IDEVN,LINLEN,PERCD,MAXGEL,IDM)
CALL YESNO(ANS,'Joint correct',
+HELPS1,HELPE1,FILEH,IDEVH,KBIN,KBOUT)
IF(ANS.NE.0) THEN
NOPT = 1
RETURN
END IF
20 CONTINUE
CALL BELL(1,KBOUT)
C DBMENU now defunct for sap - so we use RADION instead
C CALL DBMENU(2,JOPT,HELPS1,HELPE1,FILEH,IDEVH,
C +KBIN,KBOUT)
PROMPT(1) = 'Complete entry'
PROMPT(2) = 'Edit contig'
PROMPT(3) = 'Display'
PROMPT(4) = 'Edit new gel reading'
JOPT = 1
CALL RADION('Enter options', PROMPT, 4, JOPT, IHELPS,
+ IHELPE, FILEH, IDEVH, KBIN, KBOUT)
C GIVE UP
IF(JOPT.EQ.-1)THEN
CALL YESNO(ANS,'Quit',
+ HELPS1,HELPE1,FILEH,IDEVH,KBIN,KBOUT)
IF(ANS.EQ.0) THEN
NOPT = 4
RETURN
END IF
END IF
C COMPLETE JOIN
IF(JOPT.EQ.1)THEN
CALL YESNO(ANS,'Complete entry',
+ HELPS1,HELPE1,FILEH,IDEVH,KBIN,KBOUT)
IF(ANS.NE.0) GO TO 20
NOPT=3
RETURN
END IF
100 CONTINUE
IF(JOPT.EQ.4)THEN
C EDIT NEW GEL
IDIM=ABS(LNGTHG(NGELS))
CALL EDITGL(GEL,GEL2,IDIM,KBIN,KBOUT,MAXGEL,
+ HELPS2,HELPE2,FILEH,IDEVH,1)
LNGTHG(NGELS)=SIGN(IDIM,LNGTHG(NGELS))
END IF
200 CONTINUE
IF(JOPT.EQ.3)THEN
C DISPLAY
LLINO=LNBR(LINCON)
LEFTMN=X
RIGHTM=X+ABS(LNGTHG(NGELS))-1
RIGHTM=MIN(RIGHTM,RELPG(LINCON))
IF(NTYPE.EQ.2)THEN
LEFTMN=1
RIGHTM=ABS(LNGTHG(NGELS))-X+1
RIGHTM=MIN(RIGHTM,RELPG(LINCON))
END IF
CALL GETREG(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,LEFTMN,
+ RIGHTM,LREG,
+ RREG,LINCON,LLINO,IDBSIZ,KBIN,KBOUT,
+ HELPS1,HELPE1,FILEH,IDEVH,IERR)
IF(IERR.NE.0) GO TO 20
IF(NTYPE.EQ.2)GO TO 210
I1=LREG-X+1
IF(I1.GT.ABS(LNGTHG(NGELS)))GO TO 200
I2=RREG-X+1
IF(I2.GT.ABS(LNGTHG(NGELS)))GO TO 200
GO TO 230
210 CONTINUE
I1=X+LREG-1
I2=X+RREG-1
IF(I1.GT.ABS(LNGTHG(NGELS)))GO TO 200
IF(I2.GT.ABS(LNGTHG(NGELS)))GO TO 200
230 CONTINUE
CALL DSPLAY(RELPG,LNGTHG,LNBR,RNBR,GEL2,
+ LLINO,LINCON,LREG,RREG,GEL,I1,I2,2,LLINOR,IDBSIZ,IDEV,
+ KBOUT,IDEVW,IDEVN,LINLEN,PERCD,MAXGEL,IDM)
LLINO=LNBR(LINCON)
END IF
300 CONTINUE
IF(JOPT.EQ.2)THEN
C EDIT DATABASE
IF(NTYPE.EQ.2)THEN
IMAXL=1
IMAXR=ABS(LNGTHG(NGELS))-X+1
ELSE IF(NTYPE.EQ.1)THEN
IMAXL=X
IMAXR=X+ABS(LNGTHG(NGELS))-1
END IF
CALL DBEDIT(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,GEL2,
+ LINCON,IMAXL,IMAXR,IDBSIZ,KBIN,KBOUT,IDEVR,IDEVW,
+ HELPS2,HELPE2,FILEH,IDEVH,MAXGEL)
END IF
IF(JOPT.EQ.1)THEN
CALL HELP2(HELPS1,HELPE1,FILEH,IDEVH,KBIN,KBOUT)
END IF
GO TO 20
END
SUBROUTINE BREAKC(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+IDBSIZ,KBIN,KBOUT,IDEVR,IDEVW,IDEVN,
+IHELPS,IHELPE,IHELP1,IHELP2,FILEH,IDEVH,IOK)
CHARACTER FILEH*(*)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
INTEGER CLEN,CHAINL,GCLIN
EXTERNAL CLEN,CHAINL,GCLIN
C ROUTINE TO BREAK A CONTIG INTO 2
C LEFT GEL OF NEW RIGHT CONTIG IS IR
C RIGHT GEL OF NEW LEFT CONTIG IS IL
C LEFT GEL OF OLD LEFT CONTIG IS ILO
C CONTIG LINE OF OLD CONTIG IS NCONTO
C CONTIG LINE OF NEW RIGHT CONTIG IS NCONTR
C CONTIG LINE OF NEW LEFT CONTIG IS NCONTO
C LENGTH OF OLD CONTIG IS LCONTO
IOK = 1
NCONTR = IDBSIZ - NCONTS - 1
IF(NCONTR.LE.NGELS) THEN
WRITE(KBOUT,*)'Insufficient space for new contig line.'
WRITE(KBOUT,*)'Increase database size with copy'
RETURN
END IF
10 CONTINUE
MN = 0
MX = NGELS
IR = 0
CALL GETINT(MN,MX,IR,
+ 'Number of gel reading that will become a left end',
+ IVAL,KBIN,KBOUT,
+ IHELPS,IHELPE,FILEH,IDEVH,IOK)
IF(IOK.NE.0) RETURN
IF(IVAL.LT.1) RETURN
IR = IVAL
IL = LNBR(IR)
IF(IL.EQ.0)THEN
WRITE(KBOUT,*)'Gel number',IR,' is already a left end'
GO TO 10
END IF
ILO = CHAINL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+IDBSIZ,IR)
IF(ILO.EQ.0)THEN
WRITE(KBOUT,*)
+'Problem with this contig. Check logical consistency'
WRITE(KBOUT,*)'of database. Break not made'
RETURN
END IF
NCONTO = GCLIN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+IDBSIZ,ILO)
IF(NCONTO.EQ.0)THEN
WRITE(KBOUT,*)'No contig line for this contig. Check logical'
WRITE(KBOUT,*)'consistency of database. Break not made'
RETURN
END IF
LCONTO = RELPG(NCONTO)
IF(LCONTO.LT.1)THEN
WRITE(KBOUT,*)'Contig has zero length. Break not made'
RETURN
END IF
CALL CBREAK(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+IDBSIZ,KBOUT,IDEVR,IDEVW,IDEVN,IR,IL,ILO,NCONTO,NCONTR,IOK)
END
SUBROUTINE CBREAK(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+IDBSIZ,KBOUT,IDEVR,IDEVW,IDEVN,IR,IL,ILO,NCONTO,NCONTR,IOK)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
INTEGER CLEN
EXTERNAL CLEN
C ROUTINE TO BREAK A CONTIG INTO 2
C LEFT GEL OF NEW RIGHT CONTIG IS IR
C RIGHT GEL OF NEW LEFT CONTIG IS IL
C LEFT GEL OF OLD LEFT CONTIG IS ILO
C CONTIG LINE OF OLD CONTIG IS NCONTO
C CONTIG LINE OF NEW RIGHT CONTIG IS NCONTR
C CONTIG LINE OF NEW LEFT CONTIG IS NCONTO
C LENGTH OF OLD CONTIG IS LCONTO
IOK = 1
NCONTS = NCONTS + 1
C WRITE LAST LINE OF DB
WRITE(KBOUT,*)'Increasing number of contigs by 1'
CALL WRITER(IDEVR,IDBSIZ,NGELS,NCONTS,NGELS,NCONTS)
C MAKE NEW CONTIG A COPY OF OLD
RELPG(NCONTR) = RELPG(NCONTO)
LNGTHG(NCONTR) = LNGTHG(NCONTO)
LNBR(NCONTR) = IR
RNBR(NCONTR) = RNBR(NCONTO)
WRITE(KBOUT,*)'Writing new right contig line'
CALL WRITER(IDEVR,NCONTR,RELPG(NCONTR),LNGTHG(NCONTR),
+LNBR(NCONTR),RNBR(NCONTR))
C NEED LENGTH FOR OLD LEFT CONTIG
RNBR(IL) = 0
L = CLEN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+IDBSIZ,IL)
IF(L.LT.1)THEN
WRITE(KBOUT,*)
+ 'New left contig has zero length. Break not made'
RETURN
END IF
RELPG(NCONTO) = L
RNBR(NCONTO) = IL
C DO CONTIG LINE FOR NEW LEFT CONTIG
WRITE(KBOUT,*)'Writing new left contig line'
WRITE(KBOUT,*)'New length=',RELPG(NCONTO)
WRITE(KBOUT,*)'New right gel=',RNBR(NCONTO)
CALL WRITER(IDEVR,NCONTO,RELPG(NCONTO),LNGTHG(NCONTO),
+LNBR(NCONTO),RNBR(NCONTO))
C DO GEL LINE FOR RIGHT GEL OF NEW LEFT CONTIG
WRITE(KBOUT,*)'Writing new right gel of left contig'
WRITE(KBOUT,*)'Gel number=',IL
CALL WRITER(IDEVR,IL,RELPG(IL),LNGTHG(IL),
+LNBR(IL),RNBR(IL))
C DO GEL LINE FOR NEW RIGHT CONTIG
LNBR(IR) = 0
WRITE(KBOUT,*)'Writing new left gel of right contig'
WRITE(KBOUT,*)'Gel number=',IR
CALL WRITER(IDEVR,IR,RELPG(IR),LNGTHG(IR),
+LNBR(IR),RNBR(IR))
C NOW SHIFT
I = 1 - RELPG(IR)
WRITE(KBOUT,*)'Shifting gels in right contig by distance=',I
CALL SHIFTC(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDEVR,
+IDBSIZ,IR,NCONTR,I)
WRITE(KBOUT,*)'Right contig length=',RELPG(NCONTR)
WRITE(KBOUT,*)'Break completed'
IOK = 0
END
C BUBBL3
C SUBROUTINE TO SORT INTEGER ARRAY (LIST) INTO ASCENDING ORDER
C
SUBROUTINE BUBBL3(LIST,LISTEL,LISTAL,IDIM)
C AUTHOR: RODGER STADEN
INTEGER LIST(IDIM),LISTEL(IDIM),LISTAL(IDIM)
C
C SET POINTERS TO ZERO
I=0
J=0
C
10 CONTINUE
C
C SET I=J IF WE HAVE JUST CORRECTLY POSITIONED AN ELEMENT
IF(J.GT.I)I=J
C
C INCREMENT POINTER TO NEXT ELEMENT
I=I+1
C TEST FOR END OF ARRAY
IF(I.EQ.IDIM)RETURN
C
20 CONTINUE
C
C COMPARE ADJACENT ELEMENTS
IF(LIST(I).GE.LIST(I+1))GO TO 10
C
C FIRST MOVE THIS ELEMENT? IF SO SET POINTER TO ITS INITIAL POSITION
IF(J.LT.I)J=I
C
C EXCHANGE ADJACENT ELEMENTS
ITEMP=LIST(I)
LIST(I)=LIST(I+1)
LIST(I+1)=ITEMP
C
ITEMP=LISTEL(I)
LISTEL(I)=LISTEL(I+1)
LISTEL(I+1)=ITEMP
ITEMP=LISTAL(I)
LISTAL(I)=LISTAL(I+1)
LISTAL(I+1)=ITEMP
C
C
C DECREMENT BACK THRU LIST WITH THIS ELEMENT
IF(I.GT.1)I=I-1
C
GO TO 20
END
SUBROUTINE CBASE(BASE,BKEY,IOK,ICBASE,
+KBIN,KBOUT,IHELPS,IHELPE,HELPF,IDEVH)
C AUTHOR RODGER STADEN
CHARACTER BASE(4),BKEY(4),HELPF*(*),NEW(4)
CHARACTER PROMPT*14
SAVE PROMPT
DATA PROMPT/'Key for base '/
IOK = 1
CALL YESNO(ICBASE,'Use special keys for ACTG',
+IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
IF(ICBASE.EQ.1) THEN
IOK = 0
RETURN
ELSE IF(ICBASE.NE.0) THEN
RETURN
END IF
I = 1
1 CONTINUE
IF(I.LT.5) THEN
PROMPT(14:14) = BASE(I)
L = 1
CALL GETSTR(PROMPT,BKEY(I),NEW,4,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(NEW(1).EQ.';') THEN
WRITE(KBOUT,*)' ; is not allowed'
GO TO 1
END IF
IF(L.NE.0) BKEY(I) = NEW(1)
I = I + 1
GO TO 1
END IF
CALL CCASEA(BKEY,4,2)
IOK = 0
END
SUBROUTINE CCTA(SEQ,ID)
CHARACTER SEQ(ID),COM,AS
SAVE COM,AS
DATA COM/','/,AS/'*'/
DO 10 I = 1,ID
IF(SEQ(I).EQ.COM) SEQ(I) = AS
10 CONTINUE
END
SUBROUTINE CEDT(KBIN,KBOUT,
+GELNOS,GELSTR,GELEND,
+MAXDB,GELNO,LINNO,MAXLIN,RELPG,LNGTHG,LNBR,RNBR,
+IDBSIZ,NGELS,NCONTS,GEL,GEL2,MAXGEL,LINCON,PERCD,IDM,
+IHELPS,IHELPE,HELPF,IDEVH,IDEV,IDEV1,IDEV2,IDEV3,LINLEN,
+FILNAM,LLINO,IOK)
INTEGER RELPG(MAXDB),LNGTHG(MAXDB),LNBR(MAXDB),RNBR(MAXDB)
CHARACTER LINEIN*80,GEL(MAXGEL),GEL2(MAXGEL)
C AUTHOR: RODGER STADEN
CHARACTER FILNAM*(*),HELPF*(*)
INTEGER GELNOS(MAXDB),GELSTR(MAXDB),GELEND(MAXDB)
INTEGER GELNO(MAXLIN,2),LINNO(MAXLIN,2),RREG
WRITE(KBOUT,*)'Identify contig to edit'
CALL GETLN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,LINCON,
+LLINO,IOK,IDBSIZ,KBIN,KBOUT,IDEV3,
+IHELPS,IHELPE,HELPF,IDEVH)
IF(IOK.NE.0) RETURN
FILNAM = ' '
CALL OPENF1(IDEV,FILNAM,1,IOK,KBIN,KBOUT,
+'Name for temporary editing file',
+IHELPS,IHELPE,HELPF,IDEVH)
IF(IOK.NE.0) RETURN
LREG = 1
RREG = RELPG(LINCON)
CALL DSPLAY(RELPG,LNGTHG,LNBR,RNBR,
+GEL,LLINO,LINCON,LREG,RREG,GEL2,I1,I2,0,I,IDBSIZ,IDEV,KBOUT,
+IDEV2,IDEV3,LINLEN,PERCD,MAXGEL,IDM)
CLOSE(UNIT=IDEV)
CALL CEDIT(FILNAM)
CALL YESNO(IWANT,'Put edited contig into database',
+IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
IF(IWANT.NE.0) RETURN
CALL OPENRS(IDEV,FILNAM,IOK,LRECL,2)
IF(IOK.NE.0) RETURN
KGEL = LLINO
CALL BUSY(KBOUT)
CALL POSTC(GELNOS,GELSTR,GELEND,LINEIN,
+IOK,KBOUT,IDEV,MAXDB,GELNO,LINNO,MAXLIN,RELPG,LNGTHG,
+LNBR,RNBR,IDBSIZ,KGEL)
IF(IOK.NE.0) THEN
CLOSE(UNIT=IDEV)
RETURN
END IF
REWIND IDEV
CALL NEWDB(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,KBOUT,IDEV,
+IDEV1,IDEV2,IDEV3,MAXDB,GEL,MAXGEL,LINCON,KGEL,IOK)
CLOSE(UNIT=IDEV)
END
C
C CFGEL
C
C ROUTINE TO COMPARE A STRING OF WORD NUMBERS FOR A GEL WITH A SERIES
C OF ARRAYS REPRESENTING A CONSENSUS SEQUENCE. WE LOOK FOR OCCURENCES
C OF PAIRS OF WORDS (EACH WORD IS LENGTH CHARS LONG AND SO TOTAL MATCH IS
C 2*LENGTH CHARS LONG). THE ARRAYS SENT ARE OF SIZE 4**LENGTH (LE4)
SUBROUTINE CFGEL(GELN,IDIMG,POSNS,IDIM,WORDP,WORDN,LENGTH,LE4,
+SAVPG,
+SAVPS,SAVL,IDSAV,SEQ,GEL,MINMAT,IFAIL,KBOUT)
C AUTHOR: RODGER STADEN
CHARACTER SEQ(IDIM),GEL(IDIMG)
INTEGER POSNS(IDIM),WORDP(LE4),SAVPS(IDSAV),SAVPG(IDSAV)
INTEGER GELN(IDIMG),SAVL(IDSAV)
INTEGER WORDN(LE4)
INTEGER W1,W2,PS1W1,PS1W2
INTEGER CTONUM
EXTERNAL CTONUM
C bug fix 27-2-92: if sequence had different case matches would
C not be extended correctly because we look for identical characters
C switched to using ctonum
IDSAVM=IDSAV
IDSAV=0
C LENGTH OF PAIR OF WORDS
LX2=2*LENGTH
C NUMBER OF PAIRS OF WORDS OF LENGTH LENGTH IN GEL
NW=IDIMG-(LX2-1)
C LOOP FOR EACH START POINT
DO 200 I=1,NW
C IS THIS WORD A ZERO?
W1=GELN(I)
IF(W1.EQ.0)GO TO 200
C POINT TO NEXT WORD OF PAIR
W2=GELN(I+LENGTH)
IF(W2.EQ.0)GO TO 200
C DOES W1 EXIST IN SEQ?
N1S1=WORDN(W1)
IF(N1S1.EQ.0)GO TO 200
N2S1=WORDN(W2)
IF(N2S1.EQ.0)GO TO 200
C BOTH EXIST, SO POINT TO THE FIRST + LENGTH
PS1W1=WORDP(W1)+LENGTH
C LOOP FOR ALL PAIRS
DO 50 J=1,N1S1
C POINT TO FIRST W2 BECAUSE IT IS IN WORDP NOT POSNS
PS1W2=WORDP(W2)
C LOOP FOR THESE
DO 40 K=1,N2S1
C ARE THIS PAIR LENGTH APART?
N=PS1W1-PS1W2
IF(N.NE.0)GO TO 20
C THEY ARE SO, IF REQUIRED LOOK FOR REST OF MATCH
LMAT=LX2
IF(MINMAT.EQ.LX2)GO TO 15
IPC=PS1W2+LENGTH
IPG=I+LX2
16 CONTINUE
IF(IPG.GT.IDIMG)GO TO 15
IF(IPC.GT.IDIM)GO TO 15
C
IF(CTONUM(SEQ(IPC)).NE.CTONUM(GEL(IPG)))GO TO 15
LMAT=LMAT+1
IPC=IPC+1
IPG=IPG+1
GO TO 16
15 CONTINUE
C IS MATCH LONG ENOUGH?
IF(LMAT.LT.MINMAT)GO TO 20
IDSAV=IDSAV+1
IF(IDSAV.LE.IDSAVM)GO TO 18
WRITE(KBOUT,1000)IDSAVM
1000 FORMAT(' More than ',I6,' matches. Search aborted')
IFAIL=1
RETURN
18 CONTINUE
SAVL(IDSAV)=LMAT
SAVPG(IDSAV)=I
SAVPS(IDSAV)=PS1W1-LENGTH
20 CONTINUE
C POINT TO NEXT W2
PS1W2=POSNS(PS1W2)
40 CONTINUE
C ALL TRIED THIS PS1W1, TRY NEXT
PS1W1=POSNS(PS1W1-LENGTH)+LENGTH
50 CONTINUE
200 CONTINUE
IFAIL=0
RETURN
END
INTEGER FUNCTION CHAINL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+IDBSIZ,IIN)
C AUTHOR: RODGER STADEN
C RETURNS CONTIG LEFT GEL NUMBER OR ZERO FOR ERROR
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
I = IIN
J = I
CHAINL = 0
10 CONTINUE
IF(I.NE.0)THEN
J = I
I = LNBR(I)
IF(I.EQ.IIN)RETURN
GO TO 10
END IF
CHAINL = J
END
C
C CHANGE
C
C ROUTINE TO EXCHANGE ALL THE CHARS IN A CHARACTER ARRAY USING
C A PAIR OF LOOKUP ARRAYS SENT BY CALLING PROG
C
C
SUBROUTINE CHANGE(SEQ,IDIM1,CHAR1,CHAR2,IDIM2,ELSE)
C AUTHOR: RODGER STADEN
CHARACTER SEQ(IDIM1)
CHARACTER CHAR1(IDIM2),CHAR2(IDIM2)
CHARACTER ELSE
DO 100 I=1,IDIM1
C
DO 50 J=1,IDIM2
C
IF(SEQ(I).NE.CHAR1(J))GO TO 50
C MATCH SO EXCHANGE CHARS
SEQ(I)=CHAR2(J)
GO TO 100
50 CONTINUE
SEQ(I)=ELSE
100 CONTINUE
C
RETURN
END
CHARACTER*1 FUNCTION CHARSL(I)
CHARACTER C*6
SAVE C
DATA C/'ctag*-'/
CHARSL = C(I:I)
END
CHARACTER*1 FUNCTION CHARSU(I)
CHARACTER C*6
SAVE C
DATA C/'CTAG*-'/
CHARSU = C(I:I)
END
INTEGER FUNCTION CHNRP(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,LGEL,NCONT,
+LREG)
INTEGER RELPG(IDBSIZ),LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
I = LGEL
CHNRP = 0
10 CONTINUE
IF(I.NE.0) THEN
IF(RELPG(I).LE.LREG) THEN
I = RNBR(I)
GO TO 10
END IF
CHNRP = I
RETURN
END IF
END
INTEGER FUNCTION CHNRP1(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,
+LGEL,LREG)
INTEGER RELPG(IDBSIZ),LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
I = LGEL
CHNRP1 = 0
10 CONTINUE
IF(I.NE.0) THEN
IF(RELPG(I)+ABS(LNGTHG(I))-1.LT.LREG) THEN
I = RNBR(I)
GO TO 10
END IF
CHNRP1 = I
RETURN
END IF
END
INTEGER FUNCTION CLEN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+IDBSIZ,IIN)
C AUTHOR: RODGER STADEN
C RETURNS CONTIG LEFT GEL NUMBER OR ZERO FOR ERROR
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
I = IIN
CLEN= 0
LEN = 0
10 CONTINUE
IF(I.NE.0)THEN
LEN = MAX(LEN,(RELPG(I) + ABS(LNGTHG(I)) - 1))
I = RNBR(I)
IF(I.EQ.IIN)RETURN
GO TO 10
END IF
CLEN = LEN
END
SUBROUTINE CLIST(GELNO1,LINNO1,IGEL1,GELNO2,LINNO2,
+IGEL2,GELNOS,GELSTR,GELEND,IUNIQ1,IUNIQ,KBOUT,IOK)
C AUTHOR: RODGER STADEN
INTEGER GELNO1(IGEL1),GELNO2(IGEL2),GELNOS(IUNIQ1)
INTEGER GELSTR(IUNIQ1),GELEND(IUNIQ1)
INTEGER LINNO1(IGEL1),LINNO2(IGEL2)
EXTERNAL INLIST
C GELNOS === GEL NUMBERS (GELNOS)
C GELSTR === GEL START LINES
C GELEND === GEL END LINES
C GELNO === GEL NUMBERS PER STRIP
C LINNO === GEL LINE NUMBERS PER STRIP
C IGEL === NUMBER OF GELS PER STRIP
C LINENO === CURRENT LINE NUMBER
C
C WHICH GELS IN GELNO2 DO NOT APPEAR IN GELNO1
C IE HAVE STARTED IN GELNO2
DO 20 I=1,IGEL2
MATCH=INLIST(GELNO1,IGEL1,GELNO2(I))
IF(MATCH.EQ.0)THEN
C NO MATCH SO NEW
C PUT IN GELSTR
IUNIQ=IUNIQ+1
GELNOS(IUNIQ)=GELNO2(I)
GELSTR(IUNIQ)=LINNO2(I)
END IF
20 CONTINUE
C WHICH GELS IN GELNO1 DO NOT APPEAR IN GELNO2
C IE WHICH HAVE ENDED IN GELNO1
DO 10 I=1,IGEL1
MATCH=INLIST(GELNO2,IGEL2,GELNO1(I))
IF(MATCH.EQ.0)THEN
C NO MATCH SO MUST HAVE ENDED
C WHERE IS IT STORED IN GELNOS?
MATCH=INLIST(GELNOS,IUNIQ,GELNO1(I))
IF(MATCH.NE.0)THEN
GELEND(MATCH)=LINNO1(I)
GO TO 10
END IF
C ERROR
WRITE(KBOUT,1000)GELNO1(I)
1000 FORMAT( ' Error: gel number ',I5,
+ ' expected but not found in list')
IOK = 1
RETURN
END IF
10 CONTINUE
IOK = 0
RETURN
END
C
C CMPLMT
C
C SUBROUTINE TO REVERSE AND COMPLEMENT GELS AND DATA BASE
C THE POSITIONS OF THE RIGHT ENDS OF GELS ARE FIRST STORED
C IN RELPG THEN WE DO A BUBBLE SORT ON THESE POSITIONS
C UPDATING RELATIONSHIPS AS WE GO
C ALSO SEQUENCES ARE COMPLEMENTED, SIGNS OF LENGTH ARE
C MULTIPLIED BY -1 AND THE CONTIG LINE IS ALTERED
SUBROUTINE CMPLMT(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+LINCON,LLINO,GEL,IDBSIZ,KBOUT,IDEVR,IDEVW,MAXGEL)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
CHARACTER GEL(MAXGEL)
INTEGER X
C
WRITE(KBOUT,1000)LLINO
1000 FORMAT( ' Complementing contig',I6)
C CHAIN THRU AND PUT RIGHT ENDS IN RELPG
N=LLINO
10 CONTINUE
RELPG(N)=RELPG(N)+(ABS(LNGTHG(N)))-1
IF(RNBR(N).EQ.0)GO TO 20
N=RNBR(N)
GO TO 10
20 CONTINUE
C
C NOW EFFECTIVELY BUBBLE SORT ON RELPG
N=RNBR(LINCON)
GO TO 22
21 CONTINUE
N=NL
IF(I1.GT.0)N=I2
22 CONTINUE
NL=LNBR(N)
IF(NL.EQ.0)GO TO 30
I1=0
23 CONTINUE
IF(RELPG(N).GE.RELPG(NL))GO TO 21
C NOT IN CORRECT ORDER SO CHAIN ALONG UNTIL CORRECT,THEN COME
C BACK TO THIS POINT AND CONTINUE
C IF FIRST MOVE THIS LINE SET POINTER TO CURRENT POSITION
IF(I1.EQ.0)I2=N
I1=1
C
C EXCHANGE NEIGHBOURS. CURRENTLY LOOKING AT N AND ITS LEFT
C NBR, AND THE LEFT NBR IS FURTHER RIGHT THAN N
C FIX UP POINTERS TO LEFT AND RIGHT OF THESE TWO
M=LNBR(NL)
IF(M.NE.0)RNBR(M)=N
M=RNBR(N)
IF(M.NE.0)LNBR(M)=NL
LNBR(N)=LNBR(NL)
LNBR(NL)=N
RNBR(NL)=RNBR(N)
RNBR(N)=NL
C CHAIN BACK THRU LIST WITH THIS LINE
N=RNBR(NL)
IF(N.EQ.0)GO TO 21
C IE END MET
GO TO 23
30 CONTINUE
C FINISH WITH LEFT END IN N
40 CONTINUE
C NOW REVERSE NBRS SO CHAIN BACK RIGHT
NL=RNBR(N)
IF(NL.EQ.0)GO TO 50
RNBR(N)=LNBR(N)
LNBR(N)=NL
N=NL
GO TO 40
50 CONTINUE
C NEED TO FIX UP NEW LEFT END
RNBR(N)=LNBR(N)
LNBR(N)=0
C ALL POINTERS FIXED NOW DO RELATIVE POSITION
C FINISH WITH LEFT END IN N
C SO CHAIN BACK RIGHT
C SAVE RIGHT LINE NUMBER
NL=N
X=RELPG(N)
60 CONTINUE
RELPG(N)=1+(-1*(RELPG(N)-X))
IF(RNBR(N).EQ.0)GO TO 70
N=RNBR(N)
GO TO 60
70 CONTINUE
C NOW FIX CONTIG LINE
LNBR(LINCON)=NL
RNBR(LINCON)=N
C WRITE NEW CONTIG LINE
CALL WRITER(IDEVR,LINCON,RELPG(LINCON),LNGTHG(LINCON),
+LNBR(LINCON),RNBR(LINCON))
C WRITE(IDEVR,REC=LINCON)RELPG(LINCON),LNGTHG(LINCON),LNBR(LINCON),
C 1RNBR(LINCON)
C NOW REVERSE AND COMPLEMENT GELS
N=NL
80 CONTINUE
C READ(IDEVW,REC=N)GEL
CALL READW(IDEVW,N,GEL,MAXGEL)
M=ABS(LNGTHG(N))
CALL SQREV(GEL,M)
CALL SQCOM(GEL,M)
CALL WRITEW(IDEVW,N,GEL,MAXGEL)
C WRITE(IDEVW,REC=N)GEL
C CHANGE SIGNS
LNGTHG(N)=-1*LNGTHG(N)
C WRITE NEW GEL LINE
CALL WRITER(IDEVR,N,RELPG(N),LNGTHG(N),
+LNBR(N),RNBR(N))
C WRITE(IDEVR,REC=N)RELPG(N),LNGTHG(N),LNBR(N),RNBR(N)
C ANY MORE?
N=RNBR(N)
IF(N.NE.0)GO TO 80
C NO MORE
RETURN
END
C CONSEN
C CALCULATES A CONSENSUS USING THE RULES OUTLINED IN THE DOCUMENTATION
C AND SUBROUTINE SUMMER
C UNIT IDEV IS USED FOR OUTPUT
SUBROUTINE CONSEN(RELPG,LNGTHG,LNBR,RNBR,NAMPRO,NGELS,NCONTS,
+SEQ1,IDIM1,GEL,IDBSIZ,TEMP,CHRSIZ,MAXGL2,
+KBIN,KBOUT,IDEVW,IDEV,NAMCON,
+IHELPS,IHELPE,FILEH,IDEVH,MAXGEL,IDM,PERCD,IDEVN,LLINO)
CHARACTER FILEH*(*)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ),ANS,CHRSIZ
INTEGER LREG,RREG,X,Y,TEMP(CHRSIZ,MAXGL2)
CHARACTER SEQ1(IDIM1)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
CHARACTER GEL(MAXGEL)
CHARACTER NAMPRO*(*)
CHARACTER NAMCON*(*)
100 CONTINUE
ISTART=1
NAMCON = ' '
CALL OPENF1(IDEV,NAMCON,1,IOK,KBIN,KBOUT,
+'Name for consensus file',
+IHELPS,IHELPE,FILEH,IDEVH)
IF(IOK.NE.0)RETURN
CALL YESNO(ANS,'Make consensus for whole database',
+IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
IF(ANS.LT.0) RETURN
IF(ANS.EQ.1)GO TO 150
N=IDBSIZ-NCONTS
CALL BUSY(KBOUT)
DO 110 I=N,IDBSIZ-1
J=LNBR(I)
X=1
Y=RELPG(I)
IF((ISTART+19+Y).GT.IDIM1)THEN
WRITE(KBOUT,1009)IDIM1
1009 FORMAT(
+ ' Maximum consensus length(',I6,') exceeded,',/,
+ ' calculation aborted')
RETURN
END IF
CALL ADDTIT(SEQ1(ISTART),NAMPRO,J,ISTART)
CALL SUMMER(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+ SEQ1(ISTART),Y,GEL,X,Y,J,IDBSIZ,TEMP,CHRSIZ,MAXGL2,
+ IDEVW,MAXGEL,IDM,PERCD)
ISTART=ISTART+Y
110 CONTINUE
ISTART=ISTART-1
CALL FMTDK(IDEV,SEQ1,ISTART)
GO TO 400
150 CONTINUE
CALL GETLN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+LINCON,LLINO,IERR,IDBSIZ,KBIN,KBOUT,IDEVN,
+IHELPS,IHELPE,FILEH,IDEVH)
IF(IERR.NE.0)GO TO 400
CALL GETREG(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+1,RELPG(LINCON),LREG,RREG,LINCON,LLINO,IDBSIZ,KBIN,KBOUT,
+ IHELPS,IHELPE,FILEH,IDEVH,IERR)
IF(IERR.NE.0)GO TO 400
IDIM2=RREG-LREG+1
IF((ISTART+19+IDIM2).GT.IDIM1)THEN
WRITE(KBOUT,1009)IDIM1
RETURN
END IF
CALL BUSY(KBOUT)
CALL ADDTIT(SEQ1(ISTART),NAMPRO,LLINO,ISTART)
CALL SUMMER(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+SEQ1(ISTART),IDIM2,GEL,LREG,RREG,LLINO,IDBSIZ,TEMP,
+CHRSIZ,MAXGL2,IDEVW,MAXGEL,IDM,PERCD)
ISTART=ISTART+IDIM2
300 CONTINUE
CALL YESNO(ANS,'Select another contig',
+IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
IF(ANS.EQ.0) GO TO 150
ISTART=ISTART-1
CALL FMTDK(IDEV,SEQ1,ISTART)
400 CONTINUE
CALL YESNO(ANS,'Make another consensus',
+IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
IF(ANS.EQ.0)GO TO 100
RETURN
END
SUBROUTINE COPYM(JLEFTS,ILEFTS,JLC,ILC,
+JPOSC,IPOSC,JSENSE,ISENSE,JLLINO,LLINO,
+JJOINT,JOINT,JTOTPC,ITOTPC,JTOTPG,ITOTPG,
+JTYPE,ITYPE,JDOUT,IDOUT,JDIM22,IDIM22,
+SEQG3,SEQG2,SEQC3,SEQC2,PERMS,PERMIS)
CHARACTER SEQG3(JDIM22),SEQG2(JDIM22),SEQC3(JDOUT),SEQC2(JDOUT)
ILEFTS = JLEFTS
ILC = JLC
IPOSC = JPOSC
IPOSG = JPOSG
ISENSE = JSENSE
LLINO = JLLINO
JOINT = JJOINT
ITOTPC = JTOTPC
ITOTPG = JTOTPG
ITYPE = JTYPE
IDOUT = JDOUT
IDIM22 = JDIM22
CALL SQCOPY(SEQG3,SEQG2,JDIM22)
CALL SQCOPY(SEQC3,SEQC2,JDOUT)
PERMIS = PERMS
END
SUBROUTINE CRUNS(GEL,IFIRST,ILAST,RUN)
CHARACTER GEL*50,RUN*50,PAD
SAVE PAD
DATA PAD/'*'/
C MARK RUNS IN THIS CONSENSUS SO THAT
C ATGGGCC BECOMES
C ** *
RUN(1:ILAST) = ' '
DO 10 I = IFIRST+1,ILAST
C MUST ALLOW FOR THE EXTEMELY UNLIKELY CASE OF A RUN OF DASHES
C IN THE CONSENSUS
IF(GEL(I:I).NE.'-')THEN
IF(GEL(I:I).EQ.GEL(I-1:I-1)) RUN(I:I) = PAD
END IF
10 CONTINUE
END
C SUBROUTINE DALIGN
C
C COUNTS MISMATCHES AND DISPLAYS OVERLAP.
SUBROUTINE DALIGN(SEQC2,SEQG2,SEQ3,MAXGEL,IDOUT,IDIM2,
+JOINT,ITYPE,X,KBOUT,IFAIL)
C AUTHOR: RODGER STADEN
CHARACTER SEQC2(MAXGEL),SEQG2(MAXGEL),SEQ3(MAXGEL)
CHARACTER PAD,DASH
SAVE PAD,DASH
DATA PAD,DASH/',','-'/
IENDG=1
IENDC=JOINT
C ONLY LOOK AT OVERLAP WHICH IS FROM JOINT FOR LEFT TYPE JOIN
IF(ITYPE.EQ.1)THEN
IENDG=JOINT
IENDC=1
END IF
100 CONTINUE
C LENGTH OF OVERLAP?
LG=IDIM2-IENDG+1
LO=MIN(IDOUT,LG)
C SAVE RAW DATA
CALL SQCOPY(SEQG2,SEQ3,IDIM2)
CALL MSTLKL(SEQ3,IDIM2)
X=FLOAT(LO)
Y=X
K=IENDG+LO-1
C POINT TO CONSENSUS
J=0
C CHECK FOR OVERFLOW
IF(K.GT.MAXGEL)THEN
WRITE(KBOUT,1001)
1001 FORMAT(
+' Matching region too long for routine dalign. Alignment aborted')
IFAIL=1
RETURN
END IF
DO 200 I=IENDG,K
J=J+1
IF(SEQC2(J).EQ.SEQ3(I))GO TO 200
C IF(SEQ3(I).EQ.DASH)GO TO 200
C IF(SEQC2(J).EQ.DASH)GO TO 200
C IF(SEQC2(J).EQ.PAD)GO TO 200
X=X-1.
200 CONTINUE
X=(Y-X)*100./Y
WRITE(KBOUT,1000)X
1000 FORMAT(' Percentage mismatch after alignment = ',F4.1)
WRITE(KBOUT,1002)
1002 FORMAT(' Best alignment found')
CALL SQMTCH(SEQC2(1),SEQG2(IENDG),SEQ3,LO)
CALL FMT4LN(SEQC2(1),SEQG2(IENDG),SEQ3,LO,IENDC,IENDG,KBOUT)
IFAIL=0
END
C DBCHEK
C TO CHECK THE SELF CONSISTENCY OF A DB
C ARE ALL NEIGHBOURS HOLDING HANDS OR DO SOME HAVE
C GELS WHICH DO NOT BELONG TO ANY CONTIG? OR WORSE BELONG TO MORE
C THAN ONE CONTIG?
C ARE THERE ANY LOOPS IN CONTIGS (THE WORST PROBLEM)
C ARE ALL RELATIVE POSITIONS IN SAME ORDER AS NEIGHBOURS?
C ARE THERE ANY CONTIGS OF LENGTH <1 ?
C ARE THERE ANY GELS OF ZERO LENGTH ?
C RETURN ERROR CODE OF ZERO FOR ALL OK, 1 FOR GELS NOT USED
C AND 2 FOR ALL OTHER ERRORS
SUBROUTINE DBCHEK(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
+TEMP,IERR,KBOUT)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
INTEGER TEMP(IDBSIZ)
IERR=0
C HAND HOLDING OK?
DO 100 I=1,NGELS
K=LNBR(I)
IF(K.EQ.0)GO TO 50
IF(RNBR(K).EQ.I)GO TO 50
WRITE(KBOUT,1000)I
1000 FORMAT(' Hand holding problem for gel reading',I6)
WRITE(KBOUT,1001)I,RELPG(I),LNGTHG(I),LNBR(I),RNBR(I)
WRITE(KBOUT,1001)K,RELPG(K),LNGTHG(K),LNBR(K),RNBR(K)
1001 FORMAT(' ',5I6)
IERR=2
50 CONTINUE
K=RNBR(I)
IF(K.EQ.0)GO TO 100
IF(LNBR(K).EQ.I)GO TO 100
WRITE(KBOUT,1000)I
WRITE(KBOUT,1001)I,RELPG(I),LNGTHG(I),LNBR(I),RNBR(I)
WRITE(KBOUT,1001)K,RELPG(K),LNGTHG(K),LNBR(K),RNBR(K)
IERR=2
100 CONTINUE
C
C ALL GELS IN CONTIGS OR IN MORE THAN ONE CONTIG?
C TEMP IS USED TO COUNT THE NUMBER OF TIMES EACH GEL IS USED
CALL FILLI(TEMP,IDBSIZ,0)
N=IDBSIZ-NCONTS
C COUNT NUMBER OF PASSES THRU LOOP 320 TO 300. IF THIS EXCEEDS
C THE DATABASE SIZE A LOOP HAS BEEN FOUND!
ICOUNT=0
DO 300 I=N,IDBSIZ-1
II=I
K=LNBR(I)
J=RNBR(I)
IF((K.NE.0).AND.(J.NE.0))GO TO 310
C THIS CONTIG POINTS TO ZERO GEL NUMBER AS LEFT OR RIGHT END!
WRITE(KBOUT,1002)I
1002 FORMAT(' Contig',I4,' has zero gel numbers')
IERR=2
GO TO 290
310 CONTINUE
IF((LNBR(K).EQ.0).AND.(RNBR(J).EQ.0))GO TO 290
C THIS LEFT END IS NOT A LEFT END OR THIS RIGHT END IS NOT A RIGHT END
WRITE(KBOUT,1004)I
1004 FORMAT(' The end gels of contig',I4,' have outward neighbours')
IERR=2
290 CONTINUE
C DOES THE CONTIG HAVE SOME +VE LENGTH?
IF(RELPG(I).GT.0)GO TO 320
WRITE(KBOUT,1010)I
1010 FORMAT(' The contig on line number',I4,' has zero length')
IERR=2
320 CONTINUE
TEMP(K)=TEMP(K)+1
ICOUNT=ICOUNT+1
IF(ICOUNT.GT.IDBSIZ)GO TO 601
K=RNBR(K)
IF(K.NE.0)GO TO 320
300 CONTINUE
DO 400 I=1,NGELS
IF(TEMP(I).EQ.1)GO TO 390
IF(TEMP(I).EQ.0)GO TO 410
WRITE(KBOUT,1005)I,TEMP(I)
1005 FORMAT(' Gel number ',I6,' is used ',I6,' times')
IERR=2
GO TO 400
390 CONTINUE
C DOES THE GEL HAVE NONZERO LENGTH? (ONLY CHECK THOSE USED ONCE)
IF(LNGTHG(I).NE.0)GO TO 400
WRITE(KBOUT,1011)I
1011 FORMAT(' Gel number',I6,' has zero length')
IERR=2
GO TO 400
410 CONTINUE
WRITE(KBOUT,1006)I
1006 FORMAT(' Gel number ',I6,' is not used')
C NEED TO INCREMENT THE ERROR COUNT NOT RESET IT TO A LOWER VALUE!
IF(IERR.LT.2)IERR=1
400 CONTINUE
C ALL RELATIVE POSNS OK?
N=IDBSIZ-NCONTS
DO 500 I=N,IDBSIZ-1
K=LNBR(I)
IF(K.EQ.0)GO TO 500
510 CONTINUE
J=RNBR(K)
IF(J.EQ.0)GO TO 500
IF(RELPG(K).GT.RELPG(J))GO TO 520
K=J
GO TO 510
520 CONTINUE
WRITE(KBOUT,1007)K,RELPG(K),J,RELPG(J)
1007 FORMAT(' Gel number',I6,' with position',I6,
+ ' is the left neighbour of',
+ /,' gel number',I6,' with position',I6)
K=J
IERR=2
GO TO 510
500 CONTINUE
IF(IERR.EQ.0)WRITE(KBOUT,1013)
1013 FORMAT(' Database is logically consistent')
RETURN
601 CONTINUE
IERR=2
WRITE(KBOUT,1008)II
1008 FORMAT(' Loop in contig',I6,/,
+' No further checking done but gel numbers follow')
CALL FILLI(TEMP,IDBSIZ,0)
K=LNBR(II)
710 CONTINUE
TEMP(K)=TEMP(K)+1
WRITE(KBOUT,1009)K
1009 FORMAT(' ',I6)
IF(TEMP(K).GT.1)RETURN
K=RNBR(K)
GO TO 710
END
SUBROUTINE DBEDIT(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+GEL,LINCON,IMAXL,IMAXR,IDBSIZ,KBIN,KBOUT,IDEVR,IDEVW,
+IHELPS,IHELPE,FILEH,IDEVH,MAXGEL)
CHARACTER FILEH*(*)
C AUTHOR: RODGER STADEN
C SUBROUTINE TO EDIT GEL READINGS IN DATA BASE
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
INTEGER POSN,Y,X
CHARACTER GEL(MAXGEL)
CHARACTER CHARS(80),PROMPT*32
PARAMETER (MAXPRM = 32)
CHARACTER PRMPT(3)*(MAXPRM)
SAVE PROMPT
DATA PROMPT/'Characters for gel reading '/
1 CONTINUE
C CALL BELL(1,KBOUT)
C CALL DBMENU(5,NOPT,IHELPS,IHELPE,FILEH,IDEVH,
C +KBIN,KBOUT)
PRMPT(1) = 'Insert'
PRMPT(2) = 'Delete'
PRMPT(3) = 'Change'
NOPT = 1
CALL RADION('Edit options', PRMPT, 3, NOPT, IHELPS,
+ IHELPE, FILEH, IDEVH, KBIN, KBOUT)
IF(NOPT.EQ.-1)RETURN
IF(NOPT.EQ.3)GO TO 200
10 CONTINUE
MN = 1
MX = RELPG(LINCON)
POSN = 0
IF(IMAXL.GT.0) THEN
MN = IMAXL
MX = IMAXR
END IF
CALL GETINT(MN,MX,POSN,
+'Position to edit',
+IVAL,KBIN,KBOUT,
+IHELPS,IHELPE,FILEH,IDEVH,IOK)
IF(IOK.NE.0) GO TO 1
IF(IVAL.EQ.0) GO TO 1
POSN = IVAL
20 CONTINUE
MN = 1
MX = 50
NC = 1
CALL GETINT(MN,MX,NC,
+'Number of characters',
+IVAL,KBIN,KBOUT,
+IHELPS,IHELPE,FILEH,IDEVH,IOK)
IF(IOK.NE.0) GO TO 1
NC = IVAL
C NEED TO CHECK FOR DELETION TO END OF CONTIG
Y=POSN+NC
K=RELPG(LINCON)-POSN+1
IF((NOPT.EQ.2).AND.(Y.GT.RELPG(LINCON)))NC=K
C NOW FIND FIRST CHAR THAT OVERLAPS REGION
LLINO=LNBR(LINCON)
30 CONTINUE
X=RELPG(LLINO)+ABS(LNGTHG(LLINO))-1
IF(X.GE.POSN)GO TO 40
LLINO=RNBR(LLINO)
GO TO 30
40 CONTINUE
CALL READW(IDEVW,LLINO,GEL,MAXGEL)
C CALC POSN IN THIS GEL TO EDIT
K=POSN-RELPG(LLINO)+1
IF(NOPT.EQ.2)GO TO 100
50 CONTINUE
WRITE(PROMPT(28:),1005)LLINO
1005 FORMAT(I5)
LC = NC
CALL FILLC(CHARS,NC,'*')
CALL GETSTR(PROMPT,CHARS,CHARS,NC,LC,KBOUT,KBIN,INFLAG)
IF(INFLAG.EQ.2) GO TO 1
IF(INFLAG.EQ.1) THEN
CALL HELP2(IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
GO TO 50
END IF
C MOVE THE DATA RIGHT
M=ABS(LNGTHG(LLINO))
LNGTHG(LLINO)=LNGTHG(LLINO)+SIGN(NC,LNGTHG(LLINO))
N=ABS(LNGTHG(LLINO))
IF(N.GT.MAXGEL)THEN
WRITE(KBOUT,2000)LLINO
2000 FORMAT(
+' Data pushed off end of gel',I5,' During insertion')
NM512=N-MAXGEL
N=MAXGEL
C SET M SO THAT THE DATA AT THE END IS LOST
M=M-NM512
LNGTHG(LLINO)=SIGN(N,LNGTHG(LLINO))
END IF
J=M-K+1
DO 55 I=1,J
GEL(N)=GEL(M)
N=N-1
M=M-1
55 CONTINUE
C PERFORM THE INSERTION
IC=0
DO 60 I=K,MIN(MAXGEL,K+NC-1)
IC=IC+1
C DONT ALLOW SPACES - SET THEM TO *'S
IF(CHARS(IC).EQ.' ')CHARS(IC)='*'
GEL(I)=CHARS(IC)
60 CONTINUE
CALL WRITEW(IDEVW,LLINO,GEL,MAXGEL)
CALL WRITER(IDEVR,LLINO,RELPG(LLINO),LNGTHG(LLINO),
+LNBR(LLINO),RNBR(LLINO))
65 CONTINUE
LLINO=RNBR(LLINO)
IF(LLINO.EQ.0)GO TO 70
IF(RELPG(LLINO).GT.POSN)GO TO 70
X=RELPG(LLINO)+ABS(LNGTHG(LLINO))-1
IF(X.LT.POSN)GO TO 65
GO TO 40
70 CONTINUE
C INSERTS FINISHED SO NEED TO INCREMENT ALL THOSE GELS TO RIGHT
LLINO=LNBR(LINCON)
75 CONTINUE
IF(RELPG(LLINO).GT.POSN)GO TO 80
76 CONTINUE
LLINO=RNBR(LLINO)
IF(LLINO.EQ.0)GO TO 90
GO TO 75
80 CONTINUE
RELPG(LLINO)=RELPG(LLINO)+(NC)
CALL WRITER(IDEVR,LLINO,RELPG(LLINO),LNGTHG(LLINO),
+LNBR(LLINO),RNBR(LLINO))
GO TO 76
90 CONTINUE
RELPG(LINCON)=RELPG(LINCON)+(NC)
CALL WRITER(IDEVR,LINCON,RELPG(LINCON),LNGTHG(LINCON),
+LNBR(LINCON),RNBR(LINCON))
GO TO 1
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C DELETE
100 CONTINUE
C
C MOVE DATA TO LEFT
M=K+NC
C POSN TO MOVE TO
N=MAX(1,K)
C NUMBER TO MOVE
L=ABS(LNGTHG(LLINO))-M+1
C NONE TO MOVE?
IF(L.GT.0) THEN
DO 160 I=1,L
GEL(N)=GEL(M)
N=N+1
M=M+1
160 CONTINUE
END IF
C NEDE TO FIX LENGTHS AND REL POSNS OF GELS EDITED
C 3 CLASSES GELS LOSING LEFT ENDS,RIGHT ENDS,CENTRES
C FOR LEFT ENDS K<1,RIGHT ENDS L<1
C SO SET RELPG FOR THOSE LOSING LEFT ENDS
IF(K.LT.1)RELPG(LLINO)=POSN
C FIX LENGTHS
N=N-1
IF(L.GT.0)LNGTHG(LLINO)=SIGN(N,LNGTHG(LLINO))
C THOSE LOSING RIGHT ENDS
M=(POSN-RELPG(LLINO))
IF(L.LT.1)LNGTHG(LLINO)=SIGN(M,LNGTHG(LLINO))
CALL WRITER(IDEVR,LLINO,RELPG(LLINO),LNGTHG(LLINO),
+LNBR(LLINO),RNBR(LLINO))
CALL WRITEW(IDEVW,LLINO,GEL,MAXGEL)
165 CONTINUE
LLINO=RNBR(LLINO)
IF(LLINO.EQ.0)GO TO 170
C DOES IT HAVE DATA IN REGION?
X=POSN+(NC)
IF(RELPG(LLINO).GE.X)GO TO 170
X=RELPG(LLINO)+ABS(LNGTHG(LLINO))-1
IF(X.LT.POSN)GO TO 165
C WITHIN
GO TO 40
170 CONTINUE
C DELETIONS DONE SO DECREMENT ALL GELS TO RIGHT
LLINO=LNBR(LINCON)
X=POSN+(NC)
175 CONTINUE
IF(RELPG(LLINO).GE.X)GO TO 180
176 CONTINUE
LLINO=RNBR(LLINO)
IF(LLINO.EQ.0)GO TO 190
GO TO 175
180 CONTINUE
RELPG(LLINO)=RELPG(LLINO)-(NC)
CALL WRITER(IDEVR,LLINO,RELPG(LLINO),LNGTHG(LLINO),
+LNBR(LLINO),RNBR(LLINO))
GO TO 176
190 CONTINUE
RELPG(LINCON)=RELPG(LINCON)-(NC)
CALL WRITER(IDEVR,LINCON,RELPG(LINCON),LNGTHG(LINCON),
+LNBR(LINCON),RNBR(LINCON))
GO TO 1
200 CONTINUE
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C CHANGE
MN = 1
MX = NGELS
LLINO = 0
CALL GETINT(MN,MX,LLINO,'Gel number',
+IVAL,KBIN,KBOUT,
+IHELPS,IHELPE,FILEH,IDEVH,IOK)
IF(IOK.NE.0) GO TO 1
IF(IVAL.EQ.0) GO TO 200
LLINO = IVAL
WRITE(KBOUT,1022)RELPG(LLINO),LNGTHG(LLINO)
1022 FORMAT( ' This gels relative position =',I6,' and length =',I6)
220 CONTINUE
MN = RELPG(LLINO)
MX = RELPG(LLINO) + ABS(LNGTHG(LLINO)) - 1
POSN = 0
CALL GETINT(MN,MX,POSN,
+'Position to edit',
+IVAL,KBIN,KBOUT,
+IHELPS,IHELPE,FILEH,IDEVH,IOK)
IF(IOK.NE.0) GO TO 1
IF(IVAL.EQ.0) GO TO 220
POSN = IVAL
CALL READW(IDEVW,LLINO,GEL,MAXGEL)
225 CONTINUE
LC = 50
NC = 0
CALL GETSTR('New chararacters',' ',CHARS,LC,NC,KBOUT,KBIN,INFLAG)
IF(INFLAG.EQ.2) GO TO 1
IF(NC.EQ.0) GO TO 1
IF(INFLAG.EQ.1) THEN
CALL HELP2(IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
GO TO 225
END IF
K=POSN-RELPG(LLINO)+1
C COPY CHARS
DO 230 I=1,NC
IF(CHARS(I).EQ.' ')CHARS(I)='*'
GEL(K)=CHARS(I)
K=K+1
IF(K.GT.MAXGEL) GO TO 231
230 CONTINUE
231 CONTINUE
CALL WRITEW(IDEVW,LLINO,GEL,MAXGEL)
GO TO 1
END
C DBPRNT
C PRINTS A DATABASE. IE ITS RELATIONSHIPS
SUBROUTINE DBPRNT(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
+IDEV,KBIN,KBOUT,IDEVN,LLINO,
+IHELPS,IHELPE,FILEH,IDEVH)
CHARACTER FILEH*(*)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ),LREG,RREG,ANS
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
CHARACTER NAMARC*10
IF(NGELS.GT.0)CALL DBSTAT(RELPG,LNGTHG,LNBR,RNBR,NGELS,
+NCONTS,IDBSIZ,IDEV)
WRITE(IDEV,10011)NGELS,NCONTS
10011 FORMAT(' Number of gel readings',I5,' Number of contigs',I5)
20 CONTINUE
CALL YESNO(ANS,'Select contigs',
+IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
IF(ANS.LT.0) RETURN
IF(ANS.EQ.0) GO TO 45
N=IDBSIZ-NCONTS
25 CONTINUE
CALL YESNO(ANS,'Show gel readings in positional order',
+IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
IF(ANS.LT.0) RETURN
IF(ANS.EQ.0)GO TO 41
WRITE(IDEV,1009)
1009 FORMAT(' CONTIG LINES')
WRITE(IDEV,1000)
1000 FORMAT(' CONTIG LINE LENGTH ENDS'/
+' LEFT RIGHT')
DO 30 I=N,IDBSIZ-1
WRITE(IDEV,1007)I,RELPG(I),LNBR(I),RNBR(I)
30 CONTINUE
1007 FORMAT( ' ',12X,I4,2X,I6,10X,I6,2X,I6)
WRITE(IDEV,1008)
1008 FORMAT(' GEL LINES')
WRITE(IDEV,1001)
1001 FORMAT(' NAME NUMBER POSITION LENGTH NEIGHBOURS'/
+' LEFT RIGHT')
DO 40 I=1,NGELS
CALL READN(IDEVN,I,NAMARC)
WRITE(IDEV,1006)NAMARC,I,RELPG(I),LNGTHG(I),LNBR(I),RNBR(I)
1006 FORMAT( ' ',A,2X,I4,2X,I7,2X,I5,2X,I6,2X,I6)
40 CONTINUE
RETURN
C
41 CONTINUE
C
C SORTED DATA
DO 43 I=N,IDBSIZ-1
WRITE(IDEV,1021)
1021 FORMAT( )
WRITE(IDEV,1000)
WRITE(IDEV,1007)I,RELPG(I),LNBR(I),RNBR(I)
J=LNBR(I)
WRITE(IDEV,1001)
42 CONTINUE
CALL READN(IDEVN,J,NAMARC)
WRITE(IDEV,1006)NAMARC,J,RELPG(J),LNGTHG(J),LNBR(J),RNBR(J)
J=RNBR(J)
IF(J.NE.0)GO TO 42
43 CONTINUE
RETURN
45 CONTINUE
C SELECTED CONTIGS ONLY
C
C GET GEL NUMBER AND CONTIG NUMBER
CALL GETLN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,LINCON,
+LLINO,IERR,IDBSIZ,KBIN,KBOUT,IDEVN,
+IHELPS,IHELPE,FILEH,IDEVH)
IF(IERR.NE.0)RETURN
WRITE(IDEV,1009)
WRITE(IDEV,1000)
WRITE(IDEV,1007)LINCON,RELPG(LINCON),LNBR(LINCON),RNBR(LINCON)
CALL GETREG(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+1,RELPG(LINCON),LREG,RREG,LINCON,LLINO,IDBSIZ,KBIN,KBOUT,
+ IHELPS,IHELPE,FILEH,IDEVH,IERR)
IF(IERR.NE.0)RETURN
WRITE(IDEV,1008)
N=LLINO
WRITE(IDEV,1001)
46 CONTINUE
CALL READN(IDEVN,N,NAMARC)
WRITE(IDEV,1006)NAMARC,N,RELPG(N),LNGTHG(N),LNBR(N),RNBR(N)
IF(RNBR(N).EQ.0)GO TO 48
N=RNBR(N)
IF(RELPG(N).GT.RREG)GO TO 48
GO TO 46
48 CONTINUE
GO TO 45
END
SUBROUTINE DBSCAN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,SEQ1,
+IDIM1,GEL,IDBSIZ,TEMP3,ID1,CHRSIZ,MAXGL2,KBIN,KBOUT,IDEVW,
+IDEV,LINLEN,PERCD,
+IHELPS,IHELPE,FILEH,IDEVH,MAXGEL,LINOU1,LINOU2,
+MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,IDEVN,
+ LLINO,LINCON,LREG,RREG,MXGOOD)
C 28-7-91 added extra parameter mxgood: the max length of read
C we have confidence in
CHARACTER FILEH*(*)
PARAMETER (MAXPRM = 10)
CHARACTER PROMPT(2)*(MAXPRM)
C AUTHOR: RODGER STADEN
INTEGER RREG, RELPG(IDBSIZ),CHRSIZ
INTEGER LREG,TEMP3(ID1,CHRSIZ,MAXGL2),ANS
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
CHARACTER GEL(MAXGEL),LINOU1(MAXGEL),LINOU2(MAXGEL)
CHARACTER SEQ1(IDIM1)
CALL GETLN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+LINCON,LLINO,IERR,IDBSIZ,KBIN,KBOUT,IDEVN,
+IHELPS,IHELPE,FILEH,IDEVH)
IF(IERR.NE.0) RETURN
CALL GETREG(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+1,RELPG(LINCON),LREG,RREG,LINCON,LLINO,IDBSIZ,KBIN,KBOUT,
+ IHELPS,IHELPE,FILEH,IDEVH,IERR)
IF(IERR.NE.0) RETURN
IDIM2=RREG-LREG+1
CALL SUMMAR(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+SEQ1,IDIM1,GEL,LREG,RREG,LLINO,PERCD,IDBSIZ,
+TEMP3,ID1,CHRSIZ,MAXGL2,IDEVW,
+MAXGEL,LINOU1,LINOU2,MXGOOD)
CALL DBSCSM(SEQ1(LREG),IDIM2,KBOUT)
160 CONTINUE
ANS = 1
PROMPT(1) = 'List codes'
PROMPT(2) = 'Plot codes'
CALL RADION('Select results display mode',PROMPT,2,ANS,
+ IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
IF(ANS.LT.1) RETURN
IF(ANS.EQ.1) THEN
CALL FMTDB(SEQ1,IDIM1,LREG,RREG,LINLEN,IDEV)
RETURN
ELSE
CALL PLTQ(SEQ1(LREG),IDIM2,
+ MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
END IF
END
SUBROUTINE DBSCNP(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,SEQ1,
+IDIM1,GEL,IDBSIZ,TEMP3,ID1,CHRSIZ,MAXGL2,IDEVW,LLINO,
+PERCD,MAXGEL,LINOU1,LINOU2,LREG,RREG,
+MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,MXGOOD)
C AUTHOR: RODGER STADEN
INTEGER RREG, RELPG(IDBSIZ),CHRSIZ
INTEGER LREG,TEMP3(ID1,CHRSIZ,MAXGL2)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
CHARACTER GEL(MAXGEL),LINOU1(MAXGEL),LINOU2(MAXGEL)
CHARACTER SEQ1(IDIM1)
IDIM2=RREG-LREG+1
C 28-7-91 added extra parameter mxgood: the max length of read
C we have confidence in
CALL SUMMAR(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+SEQ1,IDIM1,GEL,LREG,RREG,LLINO,PERCD,IDBSIZ,
+TEMP3,ID1,CHRSIZ,MAXGL2,IDEVW,
+MAXGEL,LINOU1,LINOU2,MXGOOD)
CALL PLTQ(SEQ1(LREG),IDIM2,
+MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
END
SUBROUTINE DBSCSM(SEQ1,IDIM1,KBOUT)
C AUTHOR: RODGER STADEN
CHARACTER SEQ1(IDIM1)
CHARACTER CODES(5)
REAL X(5)
SAVE CODES
DATA CODES/'0','1','2','3','4'/
DO 50 J=1,5
X(J)=0.
50 CONTINUE
DO 100 I=1,IDIM1
DO 60 J=1,5
IF(SEQ1(I).NE.CODES(J))GO TO 60
X(J)=X(J)+1.
GO TO 61
60 CONTINUE
61 CONTINUE
100 CONTINUE
SUM=0.
DO 130 J=1,5
SUM=SUM+X(J)
130 CONTINUE
DO 140 J=1,5
IF(SUM.NE.0)X(J)=X(J)*100./SUM
140 CONTINUE
WRITE(KBOUT,1001)X(1)
1001 FORMAT(' ',F6.2,'% OK on both strands and they agree(0)')
WRITE(KBOUT,1002)X(2)
1002 FORMAT(' ',F6.2,'% OK on plus strand only(1)')
WRITE(KBOUT,1003)X(3)
1003 FORMAT(' ',F6.2,'% OK on minus strand only(2)')
WRITE(KBOUT,1004)X(4)
1004 FORMAT(' ',F6.2,'% Bad on both strands(3)')
WRITE(KBOUT,1005)X(5)
1005 FORMAT(' ',F6.2,'% OK on both strands but they disagree(4)')
RETURN
END
C DBSTAT
SUBROUTINE DBSTAT(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
+KBOUT)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
N=IDBSIZ-NCONTS
SUM=0.
DO 20 I=N,IDBSIZ-1
SUM=SUM+RELPG(I)
20 CONTINUE
AV=SUM/NCONTS
WRITE(KBOUT,1020)SUM,AV
1020 FORMAT( ' Total contig length ',F10.0,' Average',
+' length ',F10.1)
SUMG=0.
DO 30 I=1,NGELS
SUMG=SUMG+FLOAT(ABS(LNGTHG(I)))
30 CONTINUE
AV=SUMG/SUM
WRITE(KBOUT,1021)SUMG
1021 FORMAT( ' Total characters in gel readings ',F10.0)
WRITE(KBOUT,1022)AV
1022 FORMAT
+( ' Average gel characters per consensus character ',F10.2)
99 CONTINUE
RETURN
END
C DELCON
C
C DELETES CONTIG FROM CONSENSUS SEQUENCE
SUBROUTINE DELCON(SEQ1,ILEFT,ILC,IDIM1)
C AUTHOR: RODGER STADEN
CHARACTER SEQ1(IDIM1)
C FIRST CHAR TO REPLACE
I1=ILEFT-20
C FIRST CHAR TO MOVE
I2=ILEFT+ILC
C IS THIS RIGHTMOST CONTIG ANYWAY?
IF(I2.GT.IDIM1)GO TO 10
C NUMBER TO MOVE
ID=IDIM1-I2+1
C MOVE
CALL SQCOPY(SEQ1(I2),SEQ1(I1),ID)
C RESET LENGTH
IDIM1=I1+ID-1
RETURN
10 CONTINUE
C RIGHTMOST CONTIG SO DONT MOVE
IDIM1=I1-1
C
RETURN
END
SUBROUTINE DISMAT(SEQ,IDIM,GEL,IDIMG,SAVPS,SAVPG,IDSAV,
+CENDS,NENDS,IDCEND,MAXCON,KBOUT,MATCH)
C AUTHOR: RODGER STADEN
INTEGER CENDS(MAXCON)
INTEGER NENDS(MAXCON)
INTEGER SAVPS(IDSAV),SAVPG(IDSAV)
CHARACTER SEQ(IDIM),GEL(IDIMG),MATCH(IDIMG)
C EDIT 07-02-83 TO CHECK FOR CASE WHEN GEL OVERLAPS ADJACENT
C CONTIGS WITHIN THE LENGTH OF THE GEL! DONE BY HAVING A
C PARAMETER THAT STORES THE POSITION OF THE LEFT END OF THE
C NEXT CONTIG (IE THE ONE AFTER THE ONE THE CURRENT GEL OVERLAPS)
C SET IT TO A VERY LARGE VALUE INITIALLY
NEXTC=99999
C SORT THE MATCHING WORDS INTO ASCENDING ORDER ON POSITION IN SEQ
CALL BUB2AS(SAVPS,SAVPG,IDSAV)
C LOOK FOR SEPARATE MATCHES
LEND=IDIMG-SAVPG(1)+SAVPS(1)
C WRITE(KBOUT,1000)SAVPG(1),SAVPS(1)
CALL DISMAU(SEQ,IDIM,GEL,IDIMG,SAVPS(1),
+SAVPG(1),CENDS,NENDS,IDCEND,MAXCON,
+NEXTC,KBOUT,MATCH)
DO 10 I=2,IDSAV
IF((SAVPS(I).LT.LEND).AND.(SAVPS(I).LT.NEXTC))GO TO 10
C NEW MATCH, DISPLAY IT
C WRITE(KBOUT,1000)SAVPG(I),SAVPS(I)
C1000 FORMAT(' ',2I6)
CALL DISMAU(SEQ,IDIM,GEL,IDIMG,SAVPS(I),
+SAVPG(I),CENDS,NENDS,IDCEND,MAXCON,
+NEXTC,KBOUT,MATCH)
C RESET LEND
LEND=IDIMG-SAVPG(I)+SAVPS(I)
10 CONTINUE
RETURN
END
C
C DISMAU
C ROUTINE TO DISPLAY MATCHES
C EDITED 17-12-81 TO NOT SUBTRACT 1 FROM LCL AND LGR
SUBROUTINE DISMAU(SEQ,IDIM1,GEL,IDIMG,ISAVPS,SAVPG,CENDS,NENDS,
+IDCEND,MAXCON,NEXTC,KBOUT,MATCH)
C AUTHOR: RODGER STADEN
CHARACTER SEQ(IDIM1),GEL(IDIMG),MATCH(IDIMG)
INTEGER SAVPS,SAVPG,CENDS(MAXCON)
INTEGER NENDS(MAXCON)
C EDITED 07-02-83 FOR NEXTC (SEE DISMAT)
C DELETE 20 FROM END OF CONSENSUS MATCH
SAVPS=ISAVPS-19
C FIND CONTIG CONSENSUS ENDS
JJ=1
DO 5 J=2,IDCEND
IF(SAVPS.GT.CENDS(J))GO TO 5
C GONE PAST SO LAST IS THE ONE
JJ=J-1
GO TO 6
5 CONTINUE
JJ=IDCEND
6 CONTINUE
C SUBTRACT 1 FROM END
SAVPS=SAVPS-1
C LENGTH FROM MATCH TO LEFT OF CONTIG
LCL=SAVPS-CENDS(JJ)
C RIGHT
LCR=CENDS(JJ+1)-ISAVPS-1
C LEFT GEL
LGL=SAVPG-1
LGR=IDIMG-SAVPG
C NEED MIN OF EACH PAIR
LL=MIN(LCL,LGL)
LR=MIN(LCR,LGR)
C LENGTH OF OVERLAP
LM=LR+LL+1
C DISPLAY STARTS
ICL=ISAVPS-LL
IGL=SAVPG-LL
WRITE(KBOUT,1000)NENDS(JJ)
1000 FORMAT(' Match found with vector number =',I6)
CALL SQMTCH(SEQ(ICL),GEL(IGL),MATCH,LM)
L=ICL-CENDS(JJ)-19
CALL FMT4LN(SEQ(ICL),GEL(IGL),MATCH,LM,L,IGL,KBOUT)
C SAVE POSN OF END OF NEXT CONTIG
NEXTC=CENDS(JJ+1)+20
RETURN
END
SUBROUTINE DSPLAY(RELPG,LNGTHG,LNBR,RNBR,
+GEL,LLINOO,LINCON,LREG,RREG,GEL2,I1,IDIM,NOPT,
+LLINOR,IDBSIZ,IDEV,KBOUT,IDEVW,IDEVN,LINLEN,PERCD,
+MAXGEL,IDM)
C AUTHOR: RODGER STADEN
INTEGER CHRSIZ
PARAMETER (CHRSIZ = 6)
PARAMETER (IDC1 = CHRSIZ*100)
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
INTEGER LREG,RREG,X,XLS2,XLS1,XRS2,XRS1,RREG2
CHARACTER MATCH(100)
INTEGER CHARS(CHRSIZ,100),CHARS1(IDC1)
CHARACTER NAMARC*10
CHARACTER GEL(MAXGEL)
CHARACTER GEL2(MAXGEL)
INTEGER RELPOS(10),RELPO2(10)
INTEGER GELC
INTEGER RP
INTEGER LSEQNO,RSEQNO
CHARACTER LINOUT(100)
CHARACTER MUNOTP
CHARACTER GTCONC
EXTERNAL GTCONC
EQUIVALENCE (CHARS1,CHARS)
CALL FILLI(CHARS1,IDC1,0)
C SET CONTIG NUMBER
ICON=1
LLINO=LLINOO
NLEN=LINLEN/10
LSEQNO=LREG
X=LINLEN+LSEQNO-1
RSEQNO=MIN(RREG,X)
C SET LEFT GEL NUMBER FOR RIGHT CONTIG
LN2=LLINOR
C FIRST GEL NO IS LLINOO
C SET RREG FOR RIGHT CONTIG
RREG2=IDIM
C SET UP LSEQNO,RSEQNO FOR FOR NOPT=3
XLS2=I1
XRS2=RSEQNO-LSEQNO+XLS2
9 CONTINUE
C IF RIGHT CONTIG SKIP NUMBER PRINTING
IF(ICON.EQ.2)GO TO 8
C NEED TO KEEP LONGEST LINE LENGTH FOR OUTPUT OF CONSENSUS
IE=0
C SETUP AND WRITE NUMBERS
RELPOS(1)=LSEQNO+9
DO 5 I=2,NLEN
RELPOS(I)=RELPOS(I-1)+10
5 CONTINUE
WRITE(IDEV,1023)
+(RELPOS(K),K=1,MIN(NLEN,MAX(1,(RSEQNO-LSEQNO+1)/10)))
1023 FORMAT( ' ',19X,10(I9,1X))
C SET CURRENT LINE NUMBER
8 CONTINUE
GELC=LLINO
10 CONTINUE
C IS LEFT END OF CURRENT GEL >RREG
IF(RELPG(GELC).GT.RSEQNO)GO TO 200
C ALSO NEED TO KNOW IF RIGHT END ON THIS LINE (IF .LT. NO DATA
C TO DISPLAY)
X=RELPG(GELC)+ABS(LNGTHG(GELC))-1
IF(X.LT.LSEQNO)GO TO 190
CALL READW(IDEVW,GELC,GEL,MAXGEL)
CALL FILLC(LINOUT,LINLEN,' ')
CALL READN(IDEVN,GELC,NAMARC)
C
C NEED TO KNOW HOW MANY CHARS TO COPY OVER TO OUTPUT LINE
C AND WHERE IN LINE TO PUT THEM
C CURRENT LINE LEFT END IS LSEQNO,RIGHT END RSEQNO
C SO LEFT START CHAR IS
X=MAX(LSEQNO,RELPG(GELC))
C POSITION IN ARRAY LINE
LP=X-LSEQNO+1
C RIGHT END CHAR IS
X=RELPG(GELC)+ABS(LNGTHG(GELC))-1
X=MIN(RSEQNO,X)
C POSITION IN ARRAY LINE
RP=X-LSEQNO+1
C LOOK FOR LONGEST LINE
IF(RP.GT.IE)IE=RP
C NEED LEFT START IN GEL
K=LSEQNO-RELPG(GELC)+1
IF(K.LT.1)K=1
NCOP=RP-LP+1
IF(NCOP.GT.0)CALL SQCOPY(GEL(K),LINOUT(LP),NCOP)
N=LP+NCOP-1
II=K-1
IF(IDM.EQ.26)THEN
DO 50 I = LP,N
II = II + 1
CALL PCON1(GEL(II),CHARS(1,I))
50 CONTINUE
ELSE
DO 70 I=LP,N
II=II+1
JJ = INDEXS(GEL(II),JSCORE)
CHARS(JJ,I) = CHARS(JJ,I) + JSCORE
70 CONTINUE
END IF
I=SIGN(GELC,LNGTHG(GELC))
WRITE(IDEV,1020)I,NAMARC,(LINOUT(K),K=1,RP)
1020 FORMAT( ' ',I4,2X,A,2X,100A1)
C
190 CONTINUE
C NOW GET NEXT GEL TO RIGHT
GELC=RNBR(GELC)
IF(GELC.NE.0)GO TO 10
200 CONTINUE
C CALC CONSENSUS AND WRITE IT
IF(IDM.EQ.26)THEN
DO 49 I = 1,LINLEN
LINOUT(I) = MUNOTP(CHARS(1,I))
CHARS(1,I) = 0
49 CONTINUE
ELSE
DO 230 I=1,LINLEN
LINOUT(I) = GTCONC(CHARS(1,I),CHRSIZ,PERCD)
CALL FILLI(CHARS(1,I),CHRSIZ,0)
230 CONTINUE
END IF
WRITE(IDEV,1019)(LINOUT(K),K=1,IE)
C IF REQUIRED WRITE COMPARISON GEL
C WHICH OPTION IN OPERATION?
IF(NOPT.EQ.2)GO TO 52
IF(NOPT.NE.3)GO TO 250
53 CONTINUE
C ALREADY DONE THIS LINE CONTIG2?
IF(ICON.EQ.2)GO TO 54
ICON=2
C NEED TO SAVE CONSENSUS FROM LEFT CONTIG
CALL SQCOPY(LINOUT,GEL2,IE)
C SAVE VALUES FROM LEFT CONTIG
XLS1=LSEQNO
XRS1=RSEQNO
C SAVE CURRENT LEFT GEL NUMBER
LN1=LLINO
C SET UP VALUES FOR RIGHT CONTIG
LSEQNO=XLS2
RSEQNO=XRS2
C SET LEFT GEL NUMBER
LLINO=LN2
C GET NEXT GEL
GO TO 150
54 CONTINUE
C SAVE CURRENT LEFT GEL NUMBER
LN2=LLINO
C SET VALUES FOR RIGHT CONTIG NEXT PASS
XLS2=XRS2+1
XRS2=XLS2+LINLEN-1
IF(XRS2.GT.RREG2)XRS2=RREG2
C SET UP VALUES FOR LEFT CONTIG
LLINO=LN1
ICON=1
LSEQNO=XLS1
RSEQNO=XRS1
C SET DECREMENT FOR POINTER TO GEL2
MMM=I1-1
52 CONTINUE
1017 FORMAT(' NEWGEL ',100A1)
1018 FORMAT(' MISMATCH ',100A1)
1019 FORMAT(' CONSENSUS ',100A1)
1022 FORMAT( ' ',18X,100A1)
I2=I1+LINLEN-1
IF(I2.GT.IDIM)I2=IDIM
IF(NOPT.EQ.2)WRITE(IDEV,1017)(GEL2(K),K=I1,I2)
C SET DECREMENT
IF(NOPT.EQ.2)MMM=0
55 CONTINUE
CALL FILLC(MATCH,LINLEN,'*')
K=0
DO 667 J=I1,I2
K=K+1
IF(GEL2(J-MMM).EQ.LINOUT(K))MATCH(K) = ' '
667 CONTINUE
WRITE(IDEV,1018)(MATCH(K),K=1,IE)
RELPO2(1)=(I1)+9
DO 240 I=2,NLEN
RELPO2(I)=RELPO2(I-1)+10
240 CONTINUE
WRITE(IDEV,1023)(RELPO2(K),K=1,NLEN)
I1=I2+1
I2=I2+LINLEN
IF(I2.GT.IDIM)I2=IDIM
IF(I1.GT.I2)RETURN
250 CONTINUE
C
WRITE(IDEV,1021)
1021 FORMAT( )
C NEXT LINE LENGTH
C NEXT LENGTH IS OLD RIGHT +1
LSEQNO=RSEQNO+1
C NEW RIGHT IS LEFT +LENGTH
RSEQNO=LSEQNO+(LINLEN)-1
C ARE WE OVER END OF REGION
IF(RSEQNO.GT.RREG)RSEQNO=RREG
C HAVE WE FINISHED REGION COMPLETELY
IF(RSEQNO.LT.LSEQNO) RETURN
C NOT FINISHED SO NEED TO FIND CURRENT LEFT GEL NO
C CURRENT LEFT GEL IS LLINO
C
150 CONTINUE
C NEED TO KNOW IF CURRENT LEFT GELS RIGHT END IS INSIDE REGION
X=RELPG(LLINO)+ABS(LNGTHG(LLINO))-1
IF(X.GE.LSEQNO)GO TO 9
C LOOK AT NEXT GEL TO RIGHT
LLINO=RNBR(LLINO)
C MAY HAVE GONE OVER END OF CONTIG?????
IF(LLINO.GT.0)GO TO 150
300 CONTINUE
RETURN
END
SUBROUTINE EC(GEL,IDG,CON,IDC,K)
CHARACTER GEL(IDG),CON(IDC),CHARSL
EXTERNAL CHARSL,INDEXS
PARAMETER (IDASH = 6)
K = 0
DO 10 I = 1,MIN(IDC,IDG)
JC = INDEXS(CON(I),J)
IF(JC.NE.IDASH) THEN
JG = INDEXS(GEL(I),J)
IF(JG.NE.JC) THEN
GEL(I) = CHARSL(JC)
K = K + 1
END IF
END IF
10 CONTINUE
C WRITE(*,*)'NUMBER OF CHARS CORRECTED=',K
END
SUBROUTINE ED(GEL,IDG,CON,IDC,K)
CHARACTER GEL(IDG),CON(IDC),CHARSL
EXTERNAL CHARSL,INDEXS
K = 0
DO 10 I = MIN(IDC,IDG),1,-1
JC = INDEXS(CON(I),J)
IF(JC.EQ.5) THEN
IF(I.LT.IDG) CALL SQCOPY(GEL(I+1),GEL(I),IDG-I)
K = K + 1
END IF
10 CONTINUE
C WRITE(*,*)'NUMBER OF CHARS DELETED=',K
END
SUBROUTINE EDITGL(GEL,CHARS,IDIMG,KBIN,KBOUT,MAXGEL,
+IHELPS,IHELPE,FILEH,IDEVH,ISTART)
C AUTHOR: RODGER STADEN
CHARACTER FILEH*(*)
INTEGER POSN,Y
CHARACTER GEL(MAXGEL),CHARS(MAXGEL)
PARAMETER (MAXPRM = 32)
CHARACTER PRMPT(3)*(MAXPRM)
1 CONTINUE
C CALL BELL(1,KBOUT)
C CALL DBMENU(5,NOPT,IHELPS,IHELPE,FILEH,IDEVH,
C +KBIN,KBOUT)
PRMPT(1) = 'Insert'
PRMPT(2) = 'Delete'
PRMPT(3) = 'Change'
NOPT = 1
CALL RADION('Edit options', PRMPT, 3, NOPT, IHELPS,
+ IHELPE, FILEH, IDEVH, KBIN, KBOUT)
IF(NOPT.EQ.1)THEN
CALL HELP2(IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
GO TO 1
END IF
IF(NOPT.EQ.-1)RETURN
IF(NOPT.EQ.3)GO TO 200
C INSERT, DELETE
MN = ISTART
MX = ISTART + IDIMG
POSN = 0
CALL GETINT(MN,MX,POSN,
+'Position to edit',
+IVAL,KBIN,KBOUT,
+IHELPS,IHELPE,FILEH,IDEVH,IOK)
IF(IOK.NE.0) GO TO 1
IF(IVAL.EQ.0) GO TO 1
POSN = IVAL
POSN=POSN-ISTART+1
MN = 1
MX = 50
NC = 1
CALL GETINT(MN,MX,NC,
+'Number of characters',
+IVAL,KBIN,KBOUT,
+IHELPS,IHELPE,FILEH,IDEVH,IOK)
IF(IOK.NE.0) GO TO 1
NC = IVAL
Y=POSN+NC
K=IDIMG-POSN+1
IF((NOPT.EQ.2).AND.(Y.GT.IDIMG))NC=K
C CALC POSN IN THIS GEL TO EDIT
K=POSN
C IS THIS DELETE?
IF(NOPT.EQ.4)GO TO 100
50 CONTINUE
LC = NC
CALL FILLC(CHARS,NC,'*')
CALL GETSTR('characters to insert',CHARS,CHARS,NC,LC,KBOUT,KBIN,
+INFLAG)
IF(INFLAG.EQ.2) GO TO 1
IF(IFLAG.EQ.1) THEN
CALL HELP2(IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
GO TO 50
END IF
C MOVE THE DATA RIGHT
M=IDIMG
N=IDIMG+NC
C CHECK FOR OVERFLOW OF GEL
IF(N.GT.MAXGEL)THEN
WRITE(KBOUT,2000)
2000 FORMAT(' Data pushed off end of gel during insertion')
C HOW MUCH OVER?
NM512=N-MAXGEL
N=MAXGEL
C SET M SO THAT THE DATA AT THE END IS LOST
M=M-NM512
END IF
J=M-K+1
DO 55 I=1,J
GEL(N)=GEL(M)
N=N-1
M=M-1
55 CONTINUE
C PERFORM THE INSERTION
IC=0
DO 60 I=K,MIN(MAXGEL,K+NC-1)
IC=IC+1
C DONT ALLOW SPACES - SET THEM TO *'S
IF(CHARS(IC).EQ.' ')CHARS(IC)='*'
GEL(I)=CHARS(IC)
60 CONTINUE
IDIMG=MIN((IDIMG+NC),MAXGEL)
GO TO 1
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C DELETE
100 CONTINUE
C
C MOVE DATA TO LEFT
M=K+NC
C POSN TO MOVE TO
N=MAX(1,K)
C NUMBER TO MOVE
L=IDIMG-M+1
C NONE TO MOVE?
IF(L.GT.0) THEN
C MOVE THE DATA
DO 160 I=1,L
GEL(N)=GEL(M)
N=N+1
M=M+1
160 CONTINUE
END IF
C RESET LENGTH
IDIMG=IDIMG-NC
GO TO 1
200 CONTINUE
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C CHANGE
MN = ISTART
MX = ISTART + IDIMG
POSN = 0
CALL GETINT(MN,MX,POSN,
+'Position to edit',
+IVAL,KBIN,KBOUT,
+IHELPS,IHELPE,FILEH,IDEVH,IOK)
IF(IOK.NE.0) GO TO 1
IF(IVAL.EQ.0) GO TO 1
POSN = IVAL
C ADD IN START POSITION HERE
POSN=POSN-ISTART+1
225 CONTINUE
LC = 50
NC = 0
CALL GETSTR('New characters',' ',CHARS,LC,NC,KBOUT,KBIN,INFLAG)
IF(NC.EQ.0) GO TO 1
IF(INFLAG.EQ.2) GO TO 1
IF(IFLAG.EQ.1) THEN
CALL HELP2(IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
GO TO 225
END IF
C CALC POSITION IN THIS GEL TO EDIT
K=POSN
C COPY CHARS
DO 230 I=1,NC
GEL(K)=CHARS(I)
K=K+1
230 CONTINUE
GO TO 1
END
SUBROUTINE EDR(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,LGEL,NCONT,
+CON,IDC,IDEVW,IDEVR,LREG)
INTEGER RELPG(IDBSIZ),LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
CHARACTER CON(IDC)
INTEGER CHNRP
EXTERNAL CHNRP
C CHANGE RELATIVE POSITIONS FOR AE
ND = 0
DO 10 I = IDC,1,-1
IF(CON(I).EQ.'*') THEN
ND = ND + 1
K = I + LREG - 1
J = CHNRP(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,LGEL,NCONT,K)
IF(J.NE.0) THEN
CALL SHIFTC(RELPG,LNGTHG,LNBR,RNBR,IDUM,JDUM,IDEVR,
+ IDBSIZ,J,NCONT,-1)
END IF
END IF
10 CONTINUE
C WRITE(*,*)' NUMBER OF DELETIONS=',ND
END
SUBROUTINE ET(GEL,IDG,CON,IDC,K)
CHARACTER GEL(IDG),CON(IDC),CHARSL
EXTERNAL CHARSL,INDEXS
K = 0
DO 10 I = 2,MIN(IDC,IDG)
JC = INDEXS(CON(I),J)
IF(JC.NE.6) THEN
JG = INDEXS(GEL(I),J)
IF(JG.NE.JC) THEN
JNG = INDEXS(GEL(I-1),J)
JNC = INDEXS(CON(I-1),J)
IF(JNC.NE.JNG) THEN
IF((JNG.EQ.JC).AND.(JNC.EQ.JG)) THEN
GEL(I) = CHARSL(JNG)
GEL(I-1) = CHARSL(JG)
K = K + 1
END IF
END IF
END IF
END IF
10 CONTINUE
C WRITE(*,*)' NUMBER OF CHARS TRANSPOSED=',K
END
SUBROUTINE FDEPTH(RELPG,LNGTHG,LNBR,RNBR,
+IDBSIZ,LGEL,LREG,RREG,LENCON,
+MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
INTEGER RREG,DEPTHP,DEPTHM,STRAND
STRAND = 1
CALL FDPTH(RELPG,LNGTHG,LNBR,RNBR,
+IDBSIZ,LGEL,LREG,RREG,LENCON,STRAND,DEPTHP)
IF(DEPTHP.LT.0) RETURN
STRAND = -1
CALL FDPTH(RELPG,LNGTHG,LNBR,RNBR,
+IDBSIZ,LGEL,LREG,RREG,LENCON,STRAND,DEPTHM)
IF(DEPTHM.LT.0) RETURN
CALL PLTCON(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,
+MARGL,MARGR,MARGB,
+MARGT,ISXMAX,ISYMAX,LGEL,LREG,RREG,DEPTHP,DEPTHM)
END
SUBROUTINE FDPTH(RELPG,LNGTHG,LNBR,RNBR,
+IDBSIZ,LGEL,LREG,RREG,LENCON,STRAND,DEPTH)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
INTEGER RREG,DEPTH,STRAND
EXTERNAL NCDEP
C LREG = left contig position
C RREG = right '' ''
C LENCON = RREG-LREG+1
I = LGEL
DEPTH = 0
5 CONTINUE
IF(I.NE.0) THEN
IF((RELPG(I)+ABS(LNGTHG(I))-1).LT.LREG) THEN
I = RNBR(I)
GO TO 5
END IF
ELSE
DEPTH = -1
RETURN
END IF
C WRITE(*,*)'LGEL',LGEL
10 CONTINUE
IF(I.NE.0)THEN
IF(RELPG(I).LE.RREG) THEN
IF(SIGN(1,LNGTHG(I)).EQ.STRAND) THEN
K = RELPG(I) + ABS(LNGTHG(I)) -1
DEPTH = MAX(NCDEP(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,I,
+ STRAND,K),DEPTH)
END IF
I = RNBR(I)
GO TO 10
END IF
END IF
C WRITE(*,*)'DEPTH',DEPTH
END
C FIND
C
C SUBROUTINE TO FIND THE FIRST OCCURENCE OF A GIVEN STRING
C IN A GIVEN ARRAY
C
SUBROUTINE FIND(SEQ,IDIM1,STRING,IDIM2,IMATCH)
C AUTHOR: RODGER STADEN
CHARACTER SEQ(IDIM1),STRING(IDIM2),DASH
INTEGER PSEQ,PSTR
SAVE DASH
DATA DASH/'-'/
PSEQ=0
PSTR=1
IMATCH=0
C
100 CONTINUE
C
C PUT PSEQ TO WHERE THIS FAILED MATCH STARTED
PSEQ=PSEQ+1-PSTR
C
400 CONTINUE
C
PSTR=0
C
500 CONTINUE
C
C POINT TO NEXT SEQ CHAR
PSEQ=PSEQ+1
C TEST FOR END
IF(PSEQ.GT.IDIM1)GO TO 300
C POINT TO NEXT STRING CHAR
PSTR=PSTR+1
C TEST FOR DASH IN STRING
IF(STRING(PSTR).EQ.DASH)GO TO 450
C TEST FOR DASH IN SEQ
IF(SEQ(PSEQ).EQ.DASH)GO TO 400
C TEST FOR MATCH
IF(SEQ(PSEQ).NE.STRING(PSTR))GO TO 100
C
450 CONTINUE
C
C TEST FOR END OF STRING IE. WHOLE STRING MATCH
IF(PSTR.LT.IDIM2)GO TO 500
C HAVE MATCH. GET POINTER TO WHERE IT STARTED
IMATCH=PSEQ-IDIM2+1
C
300 CONTINUE
RETURN
END
SUBROUTINE FMT4LP(SEQ1,SEQ2,IDIM,ISW,ISX,IDEV,NAME1,NAME2)
C AUTHOR: RODGER STADEN
CHARACTER SEQ1(IDIM),SEQ2(IDIM),MATCH(60),NAME1*(*),NAME2*(*)
INTEGER KL(6)
ISXX=ISX
ISWW=ISW
IE=0
10 CONTINUE
IS=IE+1
IE=IE+60
IF(IE.GT.IDIM)IE=IDIM
N=IE-IS+1
N=1+(N-1)/10
C SET UP DECIMAL COUNTERS
DO 50 J=1,N
KL(J)=ISWW
ISWW=ISWW+10
50 CONTINUE
WRITE(IDEV,1001)(KL(K),K=1,N)
WRITE(IDEV,1002)NAME1,(SEQ1(K),K=IS,IE)
IL = IE - IS + 1
CALL SQMTCH(SEQ1(IS),SEQ2(IS),MATCH,IL)
WRITE(IDEV,1003)(MATCH(K),K=1,IL)
WRITE(IDEV,1002)NAME2,(SEQ2(K),K=IS,IE)
1002 FORMAT(2X,A,2X,6(10A1,1X))
1003 FORMAT(10X,6(10A1,1X))
C SET UP DECIMAL COUNTERS
DO 60 J=1,N
KL(J)=ISXX
ISXX=ISXX+10
60 CONTINUE
WRITE(IDEV,1001)(KL(K),K=1,N)
1001 FORMAT( 5X,6(I6,5X))
IF(IE.LT.IDIM) GO TO 10
END
SUBROUTINE FMTDB(SEQ1,IDIM,ISW,ISE,LINLEN,IDEV)
C NOTE SAME AS FMTSEP!
C AUTHOR: RODGER STADEN
CHARACTER SEQ1(IDIM)
INTEGER KL(12)
ISWW=ISW-1
IE=ISW-1
1 CONTINUE
WRITE(IDEV,1003)
1003 FORMAT( )
C SET UP DECIMAL COUNTERS
DO 50 J=1,LINLEN/10
ISWW=ISWW+10
KL(J)=ISWW
50 CONTINUE
IS=IE+1
IE=IE+LINLEN
IF(IE.GT.ISE)IE=ISE
WRITE(IDEV,1001)(KL(KKK),KKK=1,MIN(IE-IS+1,LINLEN)/10)
WRITE(IDEV,1002)(SEQ1(K),K=IS,IE)
1002 FORMAT( ' ',12(10A1,1X))
1001 FORMAT( ' ',12(5X,I6))
IF(IE.EQ.ISE)RETURN
GO TO 1
END
SUBROUTINE FNDCON(SEQ,IDIM,CENDS,NENDS,IDCEND,MAXCON,KBOUT)
C AUTHOR: RODGER STADEN
C STORES THEIR POSITIONS IN CENDS AND THEIR LEFT LINE NUMBERS IN NENDS
CHARACTER SEQ(IDIM),DC(3)
INTEGER CENDS(MAXCON)
INTEGER NENDS(MAXCON)
EXTERNAL IFROMC,INDEXA
IDCEND=0
DO 10 I=1,IDIM
IF(SEQ(I).NE.'<')GO TO 10
IDCEND=IDCEND+1
C PUT POSITION OF LEFT END OF CONTIG IN CENDS
CENDS(IDCEND)=I
K = INDEXA(SEQ(I),20,'.')
IF(K.EQ.0) THEN
WRITE(KBOUT,*)'Error in contig title: no dot!'
IDCEND = 0
RETURN
END IF
K = K + I
C K=I+11
DO 5 J=1,3
DC(J)=SEQ(K)
K=K+1
5 CONTINUE
NENDS(IDCEND)=IFROMC(DC,3,KBOUT)
10 CONTINUE
C STORE POSITION OF LAST CHAR +1 TO SIMPLIFY DISPLAY ROUTINES
CENDS(IDCEND+1)=IDIM+1
RETURN
END
INTEGER FUNCTION GCLIN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+IDBSIZ,IIN)
C AUTHOR: RODGER STADEN
C RETURNS CONTIG LINE NUMBER OR ZERO FOR ERROR
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
GCLIN = 0
N=IDBSIZ-NCONTS
DO 10 J=N,IDBSIZ-1
IF(LNBR(J).EQ.IIN) THEN
GCLIN = J
RETURN
END IF
10 CONTINUE
END
INTEGER FUNCTION GELID(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+LLINO,IDBSIZ,KBIN,KBOUT,IDEVN,
+IHELPS,IHELPE,FILEH,IDEVH,INFLAG)
CHARACTER FILEH*(*)
C AUTHOR: RODGER STADEN
C SEARCHES FOR ARCHIVE NAMES
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
CHARACTER NAME1*11,NAME2*10,NAME3*11,NFLAG
PARAMETER (NFLAG='/')
NAME3 = ' '
IF(LLINO.NE.0) THEN
NAME3(1:1) = NFLAG
CALL READN(IDEVN,LLINO,NAME3(2:))
END IF
GELID = 0
10 CONTINUE
L = 0
IF(LLINO.NE.0) L = 11
CALL GTSTR('Contig identfier',NAME3,
+NAME1,L,KBOUT,KBIN,INFLAG)
IF(INFLAG.EQ.2) RETURN
IF(INFLAG.EQ.4) RETURN
IF(INFLAG.EQ.3) THEN
GELID = LLINO
RETURN
END IF
IF(INFLAG.EQ.1) THEN
CALL HELP2(IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
GO TO 10
END IF
IF(NAME1(1:1).EQ.NFLAG) THEN
CALL CCASE(NAME1,1)
DO 20 I=1,NGELS
CALL READN(IDEVN,I,NAME2)
CALL CCASE(NAME2,1)
IF(NAME1(2:11).EQ.NAME2) THEN
GELID = I
RETURN
END IF
20 CONTINUE
WRITE(KBOUT,1004)NAME1(2:)
1004 FORMAT(' ',A,' is not in the database!')
ELSE
CALL RJST(NAME1)
READ(NAME1,1001,ERR=10,END=10)GELID
1001 FORMAT(I11)
IF((GELID.LT.1).OR.(GELID.GT.NGELS)) THEN
CALL ERROM(KBOUT,'Illegal gel reading number')
GO TO 10
END IF
END IF
END
SUBROUTINE GELOUT(RELPG,LNGTHG,LNBR,RNBR,MAXDB,IDBSIZ,NGELS,
+NCONTS,GEL,MAXGEL,IDEV3,IDEV4,IDEV5,IDEV1,KBIN,KBOUT,
+IHELPS,IHELPE,HELPF,IDEVH,FILNAM)
INTEGER RELPG(MAXDB)
INTEGER LNGTHG(MAXDB),LNBR(MAXDB),RNBR(MAXDB)
CHARACTER GEL(MAXGEL)
CHARACTER FILNAM*(*),HELPF*(*)
CHARACTER NAMARC*10
FILNAM = ' '
CALL OPENF1(IDEV5,FILNAM,1,IOK,KBIN,KBOUT,
+'File for names of extracted gel readings',
+IHELPS,IHELPE,HELPF,IDEVH)
IF(IOK.NE.0)RETURN
CALL YESNO(I,'Extract ends of contigs only',
+IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
IF(I.LT.0) RETURN
IF(I.EQ.0) GO TO 15
DO 10 I=1,NGELS
L=ABS(LNGTHG(I))
IF(L.GT.0)THEN
CALL READN(IDEV4,I,NAMARC)
WRITE(KBOUT,1002)NAMARC
1002 FORMAT(' ',A)
WRITE(IDEV5,1003)NAMARC
1003 FORMAT(A)
FILNAM = NAMARC
CALL OPENRS(IDEV1,FILNAM,IOK,LRECL,1)
IF(IOK.NE.0) GO TO 100
CALL READW(IDEV3,I,GEL,MAXGEL)
IF(LNGTHG(I).LT.0)THEN
CALL SQREV(GEL,L)
CALL SQCOM(GEL,L)
END IF
CALL FMTDKN(IDEV1,GEL,L)
CLOSE(UNIT=IDEV1)
END IF
10 CONTINUE
RETURN
15 CONTINUE
C NUMBER OF LINES TO PROCESS
N=IDBSIZ-NCONTS
DO 20 I=N,IDBSIZ-1
JL=LNBR(I)
JR=RNBR(I)
CALL READN(IDEV4,JL,NAMARC)
WRITE(KBOUT,1002)NAMARC
WRITE(IDEV5,1003)NAMARC
FILNAM = NAMARC
CALL OPENRS(IDEV1,NAMARC,IOK,LRECL,1)
IF(IOK.NE.0) GO TO 100
CALL READW(IDEV3,JL,GEL,MAXGEL)
L=ABS(LNGTHG(JL))
IF(LNGTHG(JL).LT.0)THEN
CALL SQREV(GEL,L)
CALL SQCOM(GEL,L)
END IF
CALL FMTDKN(IDEV1,GEL,L)
CLOSE(UNIT=IDEV1)
IF(JR.EQ.JL)GO TO 20
CALL READN(IDEV4,JR,NAMARC)
WRITE(KBOUT,1002)NAMARC
WRITE(IDEV5,1003)NAMARC
CALL OPENRS(IDEV1,NAMARC,IOK,LRECL,1)
IF(IOK.NE.0) GO TO 100
CALL READW(IDEV3,JR,GEL,MAXGEL)
L=ABS(LNGTHG(JR))
IF(LNGTHG(JR).LT.0)THEN
CALL SQREV(GEL,L)
CALL SQCOM(GEL,L)
END IF
CALL FMTDKN(IDEV1,GEL,L)
CLOSE(UNIT=IDEV1)
20 CONTINUE
RETURN
100 CONTINUE
WRITE(KBOUT,*)'Error opening file for extracted gel reading'
RETURN
END
SUBROUTINE GETLN2(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+LINCON,LLINO,IGELNO,IERR,IDBSIZ,KBIN,KBOUT,IDEVN,
+IHELPS,IHELPE,FILEH,IDEVH)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ),GELID
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
CHARACTER FILEH*(*)
EXTERNAL GELID
IERR = 1
NCONTC = GELID(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,LLINO,
+IDBSIZ,KBIN,KBOUT,IDEVN,
+IHELPS,IHELPE,FILEH,IDEVH,INFLAG)
IF(INFLAG.EQ.2) RETURN
IF(INFLAG.EQ.4) RETURN
IF(NCONTC.EQ.0) RETURN
IGELNO = NCONTC
IF(LNBR(NCONTC).NE.0) THEN
WRITE(KBOUT,1013)RELPG(NCONTC)
1013 FORMAT(' Position of this reading=',I6)
25 CONTINUE
NCONTC = LNBR(NCONTC)
IF(LNBR(NCONTC).NE.0) GO TO 25
WRITE(KBOUT,1014)NCONTC
1014 FORMAT( ' Number of leftmost reading this contig=',I6)
END IF
30 CONTINUE
N = IDBSIZ - NCONTS
DO 20 J=N,IDBSIZ-1
IF(LNBR(J).EQ.NCONTC) THEN
LINCON=J
GO TO 21
END IF
20 CONTINUE
WRITE(KBOUT,9999)
9999 FORMAT(' No contig line for this gel! Fix the database')
RETURN
21 CONTINUE
LLINO = NCONTC
IERR = 0
END
SUBROUTINE GETLN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+LINCON,LLINO,IERR,IDBSIZ,KBIN,KBOUT,IDEVN,
+IHELPS,IHELPE,FILEH,IDEVH)
CALL GETLN2(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+LINCON,LLINO,IGELNO,IERR,IDBSIZ,KBIN,KBOUT,IDEVN,
+IHELPS,IHELPE,FILEH,IDEVH)
END
SUBROUTINE GETREG(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+LEFTMN,RIGHTM,LREG,RREG,LINCON,LLINO,IDBSIZ,KBIN,KBOUT,
+ IHELPS,IHELPE,FILEH,IDEVH,IOK)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
INTEGER LREG,RREG,RIGHTM
CHARACTER FILEH*(*)
40 CONTINUE
MN = LEFTMN
MX = RIGHTM
LREG = MN
CALL GETINT(MN,MX,LREG,
+'Start position in contig',
+IVAL,KBIN,KBOUT,
+IHELPS,IHELPE,FILEH,IDEVH,IOK)
IF(IOK.NE.0) RETURN
LREG = IVAL
MN = LREG
MX = RIGHTM
RREG = MX
CALL GETINT(MN,MX,RREG,
+'End position in contig',
+IVAL,KBIN,KBOUT,
+IHELPS,IHELPE,FILEH,IDEVH,IOK)
IF(IOK.NE.0) RETURN
RREG = IVAL
C NOW FIND FIRST GEL THAT OVER LAPS
50 CONTINUE
X=RELPG(LLINO)+(ABS(LNGTHG(LLINO)))-1
IF(X.GE.LREG)GO TO 60
C NOT IN REGION
LLINO=RNBR(LLINO)
GO TO 50
60 CONTINUE
RETURN
END
SUBROUTINE GLEVEL(T,YF,YT,Y0,YP1,YP2,YM1,YM2)
CHARACTER T
IF(T.EQ.'0') THEN
YF = Y0
YT = Y0
ELSE IF(T.EQ.'1') THEN
YF = Y0
YT = YM1
ELSE IF(T.EQ.'2') THEN
YF = Y0
YT = YP1
ELSE IF(T.EQ.'3') THEN
YF = YP1
YT = YM1
ELSE IF(T.EQ.'4') THEN
YF = YP2
YT = YM2
END IF
END
CHARACTER*1 FUNCTION GTCONC(COUNTS,IDM,CUT)
INTEGER IDM
INTEGER COUNTS(IDM)
CHARACTER CHARSU
EXTERNAL CHARSU
C 8-4-92 made this routine sum counts
GTCONC = '-'
ISUM = 0
DO 5 I=1,IDM
ISUM = ISUM + COUNTS(I)
5 CONTINUE
IF(ISUM.EQ.0.) RETURN
Y = ISUM
DO 10 I = 1,IDM - 1
X = REAL(COUNTS(I))/Y
IF(X.GE.CUT) THEN
GTCONC = CHARSU(I)
RETURN
END IF
10 CONTINUE
END
SUBROUTINE HIGHLT(GELSAV,NAMSAV,NUMSAV,KBIN,KBOUT,
+IHELPS,IHELPE,HELPF,IDEVH,IDEV1,IDEV2,
+FILNAM,IOK)
CHARACTER LINEIN*119,CONSEN*100
CHARACTER GELNO*4,GEL*100,GELSAV*100,GELNAM*10
CHARACTER NAMSAV*10,NUMSAV*4
CHARACTER FILNAM*(*),HELPF*(*)
DIMENSION GELSAV(50),NAMSAV(50),NUMSAV(50)
CHARACTER PLUS*4,MINUS*4
EQUIVALENCE (LINEIN(2:2),GELNO),(LINEIN(8:8),GELNAM)
EQUIVALENCE (LINEIN(20:20),GEL)
EXTERNAL NOTIRL
CALL OPENF1(IDEV1,FILNAM,0,IOK,KBIN,KBOUT,
+'File containing contig display',
+IHELPS,IHELPE,HELPF,IDEVH)
IF(IOK.NE.0) RETURN
FILNAM = ' '
CALL OPENF1(IDEV2,FILNAM,1,IOK,KBIN,KBOUT,
+'File for problem display',
+IHELPS,IHELPE,HELPF,IDEVH)
IF(IOK.NE.0) RETURN
C
C FORMAT:
C
C12345678901234567890 10 20 30 ETC
C 12 GELNAM0000 CAGACGCGCGCGCGCGCGGATATAGTCTCTCCGCTCT
C 100 GELNAM0000 TGATACGCTCGCTCTCTCTCTCTCTCTCTTTC
C AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
C
C 70 80 ETC
C 12 GELNAM0000 AAAAAAAAAAAAAAAAAAAAAAAAAAAA
C
C
LIN = 1
CALL GTSTR('plus strand symbol',':',PLUS,LIN,KBOUT,KBIN,INFLAG)
IF(INFLAG.EQ.1) THEN
CALL HELP2(IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
GO TO 10
END IF
IF(INFLAG.EQ.2) RETURN
IF(LIN.EQ.0) PLUS = ':'
LIN = 1
CALL GTSTR('minus strand symbol','.',MINUS,LIN,KBOUT,KBIN,INFLAG)
IF(INFLAG.EQ.1) THEN
CALL HELP2(IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
GO TO 10
END IF
IF(INFLAG.EQ.2) RETURN
IF(LIN.EQ.0) MINUS = '.'
C COUNT LINE NUMBERS
LINNO=0
10 CONTINUE
C READ LINE OF NOS
READ(IDEV1,1003,END=100)LINEIN
LINNO=LINNO+1
1003 FORMAT(A)
C WRITE IT OUT AGAIN
WRITE(IDEV2,1003)LINEIN
C ZERO GEL COUNT FOR THIS STRIP
IGEL=0
20 CONTINUE
C
C READ A LINE, COULD BE 1 GEL, 2 CONSENSUS OR BLANK
C LINEIN=' '
READ(IDEV1,1003,END=100)LINEIN
LINNO=LINNO+1
C WHAT SORT OF LINE? ONLY A GEL WILL HAVE NON BLANK CHARS AT THE LEFT END
IF(LINEIN(2:5).NE.' ')THEN
C GEL LINE SO SAVE
IGEL=IGEL+1
GELSAV(IGEL)=GEL
NAMSAV(IGEL)=GELNAM
NUMSAV(IGEL)=GELNO
GO TO 20
END IF
C MUST BE CONSENSUS
CONSEN=GEL
C PROCESS THIS STRIP OF GELS (IGEL OF THEM)
DO 50 I=1,IGEL
C WHERE DOES DATA START AND END?
IFIRST=1
40 CONTINUE
IF(GELSAV(I)(IFIRST:IFIRST).NE.' ')GO TO 45
IFIRST=IFIRST+1
IF(IFIRST.LE.100)GO TO 40
C ERROR --- NO DATA FOUND
WRITE(KBOUT,1004)LINNO
1004 FORMAT(' Error on line',I6,' of file')
RETURN
45 CONTINUE
C NOW WHERE DOES IT END
ILAST=NOTIRL(GELSAV(I),100,' ')
C COMPARE WITH CONSENSUS
READ(NUMSAV(I),'(I4)',ERR=900)INTEG
IF(INTEG.GE.0)CALL IDTOD(CONSEN,GELSAV(I),IFIRST,ILAST,PLUS)
IF(INTEG.LT.0)CALL IDTOD(CONSEN,GELSAV(I),IFIRST,ILAST,MINUS)
WRITE(IDEV2,1008)NUMSAV(I),NAMSAV(I),GELSAV(I)(1:ILAST)
1008 FORMAT(' ',A,2X,A,2X,A)
50 CONTINUE
WRITE(IDEV2,1009)CONSEN
1009 FORMAT(' ',18X,A)
1006 FORMAT( )
C READ A BLANK LINE
READ(IDEV1,1003,END=100)LINEIN
LINNO=LINNO+1
WRITE(IDEV2,1003)LINEIN
C NO GO BACK FOR THE NEXT LINE OF NUMBERS
GO TO 10
100 CONTINUE
WRITE(KBOUT,1005)
1005 FORMAT(' Finished')
RETURN
900 WRITE(KBOUT,*)'Error reading gel number'
END
SUBROUTINE IDPLC(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,
+NCONTS,IX,IY,MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,
+DBTDUX,DBTDUY,NCONT,IGEL,IS)
INTEGER RELPG(IDBSIZ),LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
INTEGER CHNRP1
EXTERNAL CWORLD,CHNRP1
YMAX = ISYMAX
YMIN = 0.
XMIN = 0.
LENCON = 0
DO 10 I = IDBSIZ-NCONTS,IDBSIZ-1
LENCON = LENCON + RELPG(I)
10 CONTINUE
XMAX = LENCON
XX = CWORLD(IX,MARGL,MARGR,XMIN,XMAX)
YX = CWORLD(IY,MARGB,MARGT,YMIN,YMAX)
YINC = (YMAX-YMIN)/3.
Y = 0.
XF = XMIN
N = 0
DO 20 I = IDBSIZ-NCONTS,IDBSIZ-1
N = N + 1
XT = XF + RELPG(I)
Y = Y + YINC
IF((XX.GT.XF).AND.(XX.LT.XT)) THEN
IS = NINT(((XX-XF)/(XT-XF)) * RELPG(I))
JGEL = LNBR(I)
IGEL = CHNRP1(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,JGEL,IS)
NCONT = I
RETURN
END IF
XF = XT
IF(N.EQ.2) THEN
N = 0
Y = 0.
END IF
20 CONTINUE
IGEL = 0
NCONT = 0
END
SUBROUTINE IDTOD(TOPLIN,GEL,IFIRST,ILAST,SYMBOL)
CHARACTER TOPLIN*100,GEL*100,SYMBOL*4
DO 10 I=IFIRST,ILAST
IF(GEL(I:I).EQ.TOPLIN(I:I))GEL(I:I)=SYMBOL(1:1)
10 CONTINUE
END
INTEGER FUNCTION INDEXS(C,S)
PARAMETER (IDM = 29)
CHARACTER C
INTEGER POINTS(0:255),SCORES(IDM),IND(IDM),S
COMMON /SHOTC/POINTS
SAVE /SHOTC/
SAVE SCORES,IND
DATA
+IND/1,2,3,4,1,2,3,4,1,2,3,4,1,2,3,4,6,6,6,6,6,6,1,2,3,4,5,5,6/
C DATA DUP/'CTAG1234DVBHKLMNRY5678ctag*,-'/
C changed 28-7-91 to give 10 to old zeroes and 100 to lowercase
DATA SCORES/
+100,100,100,100,
+75,75,75,75,
+100,100,100,100,
+100,100,100,100,
+10,10,10,10,10,10,
+100,100,100,100,100,100,10/
I = ICHAR(C)
I = POINTS(I)
S = SCORES(I)
INDEXS = IND(I)
END
C ROUTINES TO CONTROL CHARACTER LOOKUP FOR SHOTGUN SEQUENCING
SUBROUTINE INITS
C AUTHOR RODGER STADEN
INTEGER POINTS(0:255)
PARAMETER (IDM = 29)
CHARACTER DUP*29
COMMON /SHOTC/POINTS
SAVE /SHOTC/
DATA DUP/'CTAG1234DVBHKLMNRY5678ctag*,-'/
C ICHAR RETURNS THE COLLATING SEQUENCE NUMBER
C I WANT 1-4 FOR ACGT
C acgt
C 1234
C BDHV
C KLMN
C 5 FOR *
C 6 FOR 5678- AND ELSE
C THE ACTUAL VALUE RETURNED BY ICHAR IS NOT PORTABLE
C SO I NEED TO INITIALIZE POINTR SO THAT THE CORRECT
C ELEMENTS CONTAIN VALUES 1 - 6
C
DO 30 I = 0,255
POINTS(I) = IDM
30 CONTINUE
DO 35 I = 1,IDM
J = ICHAR(DUP(I:I))
POINTS(J) = I
35 CONTINUE
END
FUNCTION INLIST(LIST,IDLIST,ITEM)
C AUTHOR: RODGER STADEN
C SENT LIST LIST, AND ITEM ITEM. IF IN LIST RETURNS ELEMENT NUMBER, ELSE 0
INTEGER LIST(IDLIST)
INLIST=0
DO 1 I=1,IDLIST
IF(LIST(I).NE.ITEM)GO TO 1
INLIST=I
RETURN
1 CONTINUE
RETURN
END
SUBROUTINE IPLTC(RELPG,LNGTHG,LNBR,RNBR,
+IDBSIZ,LGEL,LREG,RREG,STRAND,
+MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,YMID,YINC,DEPTH,X,Y,KBOUT,
+IGEL,IOK)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
INTEGER RREG,STRAND,DEPTH
IOK = 1
XMIN = LREG
XMAX = RREG
YMAX = ISYMAX
YMIN = 0.
YINCO2 = STRAND*YINC/2.
I = LGEL
IGEL = 0
5 CONTINUE
IF(I.NE.0) THEN
IF((RELPG(I)+ABS(LNGTHG(I))-1).LT.LREG) THEN
I = RNBR(I)
GO TO 5
END IF
END IF
N = 0
10 CONTINUE
IF(I.NE.0)THEN
IF(RELPG(I).LE.RREG) THEN
IF(SIGN(1,LNGTHG(I)).EQ.STRAND) THEN
XF = MAX(RELPG(I),LREG)
XT = MIN(ABS(LNGTHG(I))+RELPG(I)-1,RREG)
N = N + 1
IF(N.GT.DEPTH) N = 1
YF = YMID + N * YINC
IF((X.GE.XF).AND.(X.LE.XT)) THEN
IGEL = I
IF((Y.GE.YF-YINCO2).AND.(Y.LE.YF+YINCO2)) THEN
IOK = 0
RETURN
END IF
END IF
END IF
I = RNBR(I)
GO TO 10
END IF
END IF
END
SUBROUTINE JOIN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+LNCONL,LLINOL,LNCONR,LLINOR,GEL,GEL2,
+IDBSIZ,IDEV,KBIN,KBOUT,IDEVR,IDEVW,IDEVN,LINLEN,PERCD,
+HELPS1,HELPE1,HELPS2,HELPE2,FILEH,IDEVH,MAXGEL,IDM)
CHARACTER FILEH*(*)
INTEGER HELPS1,HELPE1,HELPS2,HELPE2
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ),ANS
INTEGER LREG,RREG,X,RELX,RIGHTM
INTEGER LNGTHG(IDBSIZ),RNBR(IDBSIZ),LNBR(IDBSIZ)
CHARACTER GEL(MAXGEL),GEL2(MAXGEL)
PARAMETER (MAXPRM = 32)
CHARACTER PRMPT(5)*(MAXPRM)
15 CONTINUE
WRITE(KBOUT,1001)
1001 FORMAT(
+' The joint is the position in the left contig that',/,
+' the first character of the right contig overlaps.')
MN = 1
MX = RELPG(LNCONL)
RELX = 0
CALL GETINT(MN,MX,RELX,
+'Position of join',
+IVAL,KBIN,KBOUT,HELPS1,HELPE1,FILEH,IDEVH,IOK)
IF(IOK.NE.0) RETURN
IF(IVAL.EQ.0) RETURN
RELX = IVAL
I1=1
I2=LINLEN
IF((RELPG(LNCONR)).LT.I2)I2=(RELPG(LNCONR))
CALL DSPLAY(RELPG,LNGTHG,LNBR,RNBR,GEL2,
+LLINOL,LNCONL,RELX,RELPG(LNCONL),GEL,I1,I2,3,LLINOR,
+IDBSIZ,IDEV,KBOUT,IDEVW,IDEVN,LINLEN,PERCD,MAXGEL,IDM)
30 CONTINUE
CALL BELL(1,KBOUT)
C CALL DBMENU(3,NOPT,HELPS1,HELPE1,FILEH,IDEVH,
C +KBIN,KBOUT)
PRMPT(1) = 'Complete join'
PRMPT(2) = 'Edit left contig'
PRMPT(3) = 'Display join'
PRMPT(4) = 'Edit right contig'
PRMPT(5) = 'Move join'
NOPT = 1
CALL RADION('Join options', PRMPT, 4, NOPT, IHELPS,
+ IHELPE, FILEH, IDEVH, KBIN, KBOUT)
IF(NOPT.LT.1)RETURN
100 CONTINUE
IF(NOPT.EQ.5)GO TO 15
IF(NOPT.EQ.2)THEN
C EDIT LEFT CONTIG
IMAXL=RELX
IMAXR=MIN(RELPG(LNCONL),(RELX+RELPG(LNCONR)-1))
CALL DBEDIT(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,GEL2,
+ LNCONL,IMAXL,IMAXR,IDBSIZ,KBIN,KBOUT,IDEVR,IDEVW,
+ HELPS2,HELPE2,FILEH,IDEVH,MAXGEL)
END IF
200 CONTINUE
IF(NOPT.EQ.4)THEN
C EDIT RIGHT CONTIG
IMAXL=1
IMAXR=MIN((RELPG(LNCONL)-RELX+1),RELPG(LNCONR))
CALL DBEDIT(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,GEL2,
+ LNCONR,IMAXL,IMAXR,IDBSIZ,KBIN,KBOUT,IDEVR,IDEVW,
+ HELPS2,HELPE2,FILEH,IDEVH,MAXGEL)
END IF
300 CONTINUE
IF(NOPT.EQ.3)THEN
C DISPLAY
LLINO=LLINOL
LEFTMN=RELX
RIGHTM=RELPG(LNCONL)
IF((RIGHTM-LEFTMN+1).GT.RELPG(LNCONR))RIGHTM=
+ LEFTMN+RELPG(LNCONR)-1
CALL GETREG(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+ LEFTMN,RIGHTM,LREG,RREG,
+ LNCONL,LLINO,IDBSIZ,KBIN,KBOUT,
+ HELPS1,HELPE1,FILEH,IDEVH,IERR)
IF(IERR.NE.0) GO TO 30
I1=(LREG-RELX)+1
I2=(RREG-RELX)+1
CALL DSPLAY(RELPG,LNGTHG,LNBR,RNBR,GEL2,LLINO,
+ LNCONL,LREG,RREG,GEL,I1,I2,3,LLINOR,IDBSIZ,IDEV,KBOUT,
+ IDEVW,IDEVN,LINLEN,PERCD,MAXGEL,IDM)
END IF
40 CONTINUE
IF(NOPT.EQ.1)THEN
C COMPLETE JOIN
CALL YESNO(ANS,'Sure',
+ HELPS1,HELPE1,FILEH,IDEVH,KBIN,KBOUT)
IF(ANS.LT.0) RETURN
IF(ANS.NE.0) GO TO 30
C ADJUST ALL RELATIVE POSITIONS IN RIGHT CONTIG
N=LLINOR
RELPG(N)=RELX
50 CONTINUE
IF(RNBR(N).EQ.0)GO TO 60
N=RNBR(N)
RELPG(N)=RELPG(N)+RELX-1
GO TO 50
60 CONTINUE
C
C FIX UP NEW GEL LINE FOR OLD LEFT OF RIGHT CONTIG
LNBR(LLINOR)=RNBR(LNCONL)
C FIX UP RIGHT GEL OF LEFT CONTIG
N=RNBR(LNCONL)
RNBR(N)=LLINOR
CALL MERGE(RELPG,LNGTHG,LNBR,RNBR,LNCONL,IDBSIZ)
C MERGE DOES NOT WRITE TO DISK
N=LNBR(LNCONL)
65 CONTINUE
CALL WRITER(IDEVR,N,RELPG(N),LNGTHG(N),
+LNBR(N),RNBR(N))
N=RNBR(N)
IF(N.NE.0)GO TO 65
C CONTIG LINES
X=RELPG(LNCONR)+RELX-1
IF(X.GT.RELPG(LNCONL))RELPG(LNCONL)=X
CALL WRITER(IDEVR,LNCONL,RELPG(LNCONL),LNGTHG(LNCONL),
+LNBR(LNCONL),RNBR(LNCONL))
C NOW MOVE ALL DATA DOWN TO DELETE OLD RIGHT END
N=IDBSIZ-NCONTS
M=LNCONR-N
IF(M.EQ.0)GO TO 80
K=LNCONR
J=LNCONR-1
DO 70 I=1,M
RELPG(K)=RELPG(J)
LNGTHG(K)=LNGTHG(J)
LNBR(K)=LNBR(J)
RNBR(K)=RNBR(J)
CALL WRITER(IDEVR,K,RELPG(K),LNGTHG(K),
+LNBR(K),RNBR(K))
K=K-1
J=J-1
70 CONTINUE
80 CONTINUE
NCONTS=NCONTS-1
CALL WRITER(IDEVR,IDBSIZ,NGELS,NCONTS,NGELS,NCONTS)
RETURN
END IF
GO TO 30
END
C LINEUP
C
C TAKES 2 SEQS SET OF MATCHES AND PRODUCES LINED UP SEQS
C FINDS IF WE HAVE A LEFT OVERLAP
C RETURNS POSITION OF JOINT. THIS IS RELATIVE TO THE CONTIG
C FOR MOST MATCHES BUT I RELATIVE TO THE GEL FOR A LEFT OVERLAP
SUBROUTINE LINEUP(SEQG,SEQC,SEQG2,SEQC2,IDC,IDG,IDOUT,
1MATG,MATC,MATL,IP,ITOTPC,ITOTPG,JOINT,ITYPE,KBOUT,MAXGEL,IFAIL)
C AUTHOR: RODGER STADEN
CHARACTER SEQG(IDG),SEQC(IDC),SEQG2(IDOUT),SEQC2(IDOUT),PAD
INTEGER MATG(IP),MATC(IP),MATL(IP)
SAVE PAD
DATA PAD/','/
IFAIL=0
C ZERO PADDING CHARS IN CONTIG (GEL DONE AT END BY DIFFERENCE
C IN INPUT AND OUTPUT LENGTHS)
ITOTPC=0
C FILL OUTPUT WITH PADDING
DO 10 I=1,IDOUT
SEQG2(I)=PAD
SEQC2(I)=PAD
10 CONTINUE
NMTCH=0
C SET INITIAL POINTERS TO OUTPUT
C CONSENSUS
IS1=1
C GEL
IS2=1
C FIND DISTANCE FROM LEFT MATCH IN GEL TO LEFT OF GEL
IG2=MATG(1)-1
IF(IG2.EQ.0)THEN
C THE LEFT END OF THE GEL MATCHES SO THIS IS NOT A LEFT OVERLAP
C SET TYPE
ITYPE=-1
C SET JOINT
JOINT=MATC(1)
C SKIP NEXT SECTION
GO TO 50
END IF
C FIND DISTANCE FROM LEFT MATCH IN CONTIG TO LEFT OF CONTIG
IC2=MATC(1)-1
C GET DISTANCE FROM FIRST MATCH IN CONTIG TO FIRST MATCH IN GEL.
C IF THIS DISTANCE <0 THEN WE HAVE A LEFT OVERLAP
IC1=IC2-IG2+1
IF(IC1.GT.0)THEN
C THIS IS NOT A LEFT OVERLAP
C SET TYPE
ITYPE=-1
C SET LEFT END
JOINT=IC1
C COPY THE GEL UPTO THE FIRST MATCH, INTO THE OUTPUT ARRAY
C CHECK FOR OVERFLOW
IF(IG2.GT.MAXGEL)GO TO 700
CALL SQCOPY(SEQG(1),SEQG2(1),IG2)
C COPY THE CONTIG FOR THE SAME REGION
IF(IG2.GT.MAXGEL)GO TO 700
CALL SQCOPY(SEQC(IC1),SEQC2(1),IG2)
IS1=IS1+IG2
IS2=IS2+IG2
GO TO 50
END IF
C MUST BE LEFT END OVERLAP
C SET TYPE
ITYPE=1
C SET POSITION OF JOINT RELATIVE TO GEL
JOINT=ABS(IC1)+2
C COPY OVER THE GEL UPTO THE JOINT
C CHECK FOR OVERFLOW
IF(IG2.GT.MAXGEL)GO TO 700
CALL SQCOPY(SEQG(1),SEQG2(1),IG2)
IS2=IS2+IG2
C WE MAY ALSO HAVE MISMATCHING
C DATA AT THE JOIN SO DEAL WITH THAT NOW
C IF IC2 >0 THE LEFT END OF THE CONTIG MATCHES THE GEL BUT OTHERWISE
C WE HAVE SOME MISMATCHED DATA TO DEAL WITH - WE NEED TO TRANSFER
C THE MISMATCHED REGION OF THE CONTIG TO THE OUTPUT ARRAY
IF(IC2.GT.0)THEN
IF(IC2.GT.MAXGEL)GO TO 700
CALL SQCOPY(SEQC(1),SEQC2(1),IC2)
IS1=IS1+IC2
END IF
C WHEN WE GET HERE WE HAVE SORTED OUT THE LEFT ENDS FOR LEFT OVERLAP
C AND MISMATCHED LEFT ENDS, WE NOW DEAL WITH THE REST OF THE SEQUENCE
C STARTING WITH THE FIRST BLOCK OF IDENTITY
C
C IG1 POSITION IN INPUT GEL
C IS2 POSITION IN OUTPUT GEL
C IC1 POSITION IN INPUT CONTIG
C IS1 POSITION IN OUTPUT CONTIG
C LG1 POSITION OF END OF CURRENT MATCH IN OUTPUT GEL
C LC1 POSITION OF END OF CURRENT MATCH IN OUTPUT CONTIG
C LG2 DISTANCE FROM CURRENT MATCH IN INPUT GEL TO NEXT MATCH
C LC2 DISTANCE FROM CURRENT MATCH IN INPUT CONTIG TO NEXT MATCH
C
50 CONTINUE
C POINT TO NEXT MATCH
NMTCH=NMTCH+1
C COPY NEXT MATCH
IG1=MATG(NMTCH)
IC1=MATC(NMTCH)
L=MATL(NMTCH)
C CHECK FOR OVERFLOW
IF(IS2+L-1.GT.MAXGEL)GO TO 700
CALL SQCOPY(SEQG(IG1),SEQG2(IS2),L)
C CHECK FOR OVERFLOW
IF(IS1+L-1.GT.MAXGEL)GO TO 700
CALL SQCOPY(SEQC(IC1),SEQC2(IS1),L)
C POINT TO NEXT OUTPUT POSITIONS
IS1=IS1+L
IS2=IS2+L
C END OF CURRENT MATCH
LG1=IG1+L
LC1=IC1+L
C ANY MORE MATCHES
IF(NMTCH.EQ.IP)GO TO 500
K=NMTCH+1
LG2=MATG(K)-LG1
LC2=MATC(K)-LC1
C ANY DIFFERENCE IN LENGTH? IF SO WE HAVE TO PAD SO THEY BECOME THE SAME
L5=ABS(LG2-LC2)
C COUNT PADDING CHARS IN CONTIG
IF(LG2.GT.LC2)ITOTPC=ITOTPC+L5
C IF DIFFERENCE INCREMENT SHORTER
IF(LG2.GT.LC2)IS1=IS1+L5
C IF GEL NEEDS PADDING TRY TO PUT PADS NEXT TO DOUBLE CODES
IF(LC2.GT.LG2)CALL PADCOP(SEQG,SEQG2,
+LG1,MATG(K),L5,IS2,LG2,MAXGEL,IFAIL,KBOUT,SEQC,LC1)
C CHECK FOR OVERFLOW
IF(IFAIL.EQ.1)GO TO 700
C NOW COPY MISSMATCHED REGION
C CHECK FOR OVERFLOW
IF(IS2+LG2-1.GT.MAXGEL)GO TO 700
IF(LG2.GT.0)CALL SQCOPY(SEQG(LG1),SEQG2(IS2),LG2)
C CHECK FOR OVERFLOW
IF(IS1+LC2-1.GT.MAXGEL)GO TO 700
IF(LC2.GT.0)CALL SQCOPY(SEQC(LC1),SEQC2(IS1),LC2)
C POINT TO NEXT OUTPUT POSITIONS
IS1=IS1+LC2
IS2=IS2+LG2
C GET NEXT MATCH
GO TO 50
500 CONTINUE
C
C FINISH RIGHT ENDS
C ONLY COPY TO END OF GEL IN GEL AND TO THE SAME RELATIVE POSITION
C IN THE CONTIG FOR DISPLAY PURPOSES AND FOR COUNTING MISMATCH
C CURRENT ENDS AT LG1,LC1
C HOW FAR TO END OF GEL?
C SET M
M=0
L=IDG-LG1+1
IF(L.LT.1)GO TO 600
C CHECK FOR OVERFLOW
IF(IS2+L-1.GT.MAXGEL)GO TO 700
CALL SQCOPY(SEQG(LG1),SEQG2(IS2),L)
C NEED TO COPY TO END OF GEL IN CONTIG FOR DISPLAY
C POINT TO POSN IN CONTIG LEVEL WITH END OF GEL
M=LC1+L-1
C IS THIS OVER END OF CONTIG?
IF(M.GT.IDC)M=IDC
C NUMBER TO COPY
M=M-LC1+1
C CHECK FOR OVERFLOW
IF(IS1+M-1.GT.MAXGEL)GO TO 700
IF(M.GT.0)CALL SQCOPY(SEQC(LC1),SEQC2(IS1),M)
600 CONTINUE
C COUNT PADDING IN GEL
ITOTPG=IS2+L-1-IDG
C SET NEW LENGTHS FOR RETURN TO CALLING ROUTINE
IDOUT=IS1+M-1
IDG=IS2+L-1
IFAIL=0
RETURN
700 CONTINUE
WRITE(KBOUT,1000)
1000 FORMAT(' Matching region too long for routine lineup,',
+' alignment aborted')
IFAIL=1
RETURN
END
SUBROUTINE LSTCON(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,LLINO,
+RREG,IDEV,IDEVN,NAMARC)
INTEGER RELPG(IDBSIZ),LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
INTEGER RREG
CHARACTER NAMARC*(*)
N = LLINO
WRITE(IDEV,1001)
10 CONTINUE
CALL READN(IDEVN,N,NAMARC)
WRITE(IDEV,1006)NAMARC,N,RELPG(N),LNGTHG(N),LNBR(N),RNBR(N)
IF(RNBR(N).NE.0) THEN
N = RNBR(N)
IF(RELPG(N).LE.RREG) GO TO 10
END IF
1001 FORMAT(' NAME NUMBER POSITION LENGTH NEIGHBOURS'/
+' LEFT RIGHT')
1006 FORMAT( ' ',A,2X,I4,2X,I7,2X,I5,2X,I6,2X,I6)
END
C12345678901234567890
C 710 720 730 740 750
C -1 HINW.004 CGTCAGACGCACGCTGGAAAA
INTEGER FUNCTION LTYPE(LINE,LL,J1,J2,N,MAXDB,KBOUT)
CHARACTER LINE*(*),NUM*5,SPACE
EXTERNAL NOTRL,NOTLR
PARAMETER (SPACE= ' ')
J1 = NOTLR(LINE,LL,SPACE)
IF(J1.EQ.0) THEN
C BLANK LINE
LTYPE = 1
RETURN
END IF
IF(J1.GT.20) THEN
C LINE OF NUMBERS
LTYPE = 2
RETURN
END IF
IF(J1.GT.5) THEN
C CONSENSUS LINE
LTYPE = 3
RETURN
END IF
C SHOULD BE A SEQUENCE LINE
J = INDEX(LINE(J1:),SPACE)
NUM = SPACE
NUM = LINE(J1:J1+J-2)
CALL RJST(NUM)
C N = IFROMS(NUM,5,KBOUT)
READ(NUM,'(I5)',ERR=10) N
IF(N.GT.MAXDB-2) GO TO 10
C NUMBER ENDS AT J1+J-2
J1 = J1 + J - 1
C LOOK FOR BEGINNING OF NAME
J = NOTLR(LINE(J1:),LL-J1+1,SPACE)
N1 = J1 + J - 1
C LOOK FOR END OF NAME
J = INDEX(LINE(N1:),SPACE)
N2 = N1 + J - 2
C LOOK FOR BEGINNING OF SEQ
J = NOTLR(LINE(N2+1:),LL-N2,SPACE)
J1 = N2 + J
LTYPE = 4
C LOOK FOR END OF SEQ
J2 = NOTRL(LINE,LL,SPACE)
IF(J2.GT.N2) RETURN
10 CONTINUE
LTYPE = 0
END
INTEGER FUNCTION LWRAPS(I,J)
K = MOD(I,J)
IF(K.EQ.0) K = J
LWRAPS = K
END
C MERGE
C
C ROUTINE SENT CONTIG WHOSE GELS MAY BE OUT OF ORDER
C REORDERS GELS ON POSITION OF LEFT ENDS AND SETS LEFT
C GEL NUMBER FOR THE REORDERED CONTIG
C
SUBROUTINE MERGE(RELPG,LNGTHG,LNBR,RNBR,LINCON,IDBSIZ)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
C
C START AT LEFT END
N=LNBR(LINCON)
GO TO 22
21 CONTINUE
C SET POINTER TO NEXT GEL TO RIGHT IN LIST
N=NR
IF(I1.GT.0)N=I2
22 CONTINUE
C SET POINTER TO NEXT GEL TO RIGHT
NR=RNBR(N)
IF(NR.EQ.0)GO TO 30
C HAVENT REACHED END YET
I1=0
23 CONTINUE
C ARE THESE 2 IN CORRECT ORDER IE N<=NR ?
IF(RELPG(N).LE.RELPG(NR))GO TO 21
C NOT IN ORDER SO CHAIN LEFT UNTIL CORRECTLY POSITIONED
C THEN COME BACK TO THIS POINT AND CONTINUE
C IF FIRST MOVE SAVE POSITION
IF(I1.EQ.0)I2=N
I1=1
C EXCHANGE NEIGHBOURS
M=RNBR(NR)
IF(M.NE.0)LNBR(M)=N
M=LNBR(N)
IF(M.NE.0)RNBR(M)=NR
RNBR(N)=RNBR(NR)
RNBR(NR)=N
LNBR(NR)=LNBR(N)
LNBR(N)=NR
C CHAIN BACK THRU LIST
N=LNBR(NR)
IF(N.EQ.0)GO TO 21
C END NOT REACHED
GO TO 23
30 CONTINUE
C ALL DONE POINTER AT RIGHT GEL
RNBR(LINCON)=N
RETURN
END
SUBROUTINE MINCOM(SEQ1,IDIM1,SEQ2,IDIM2,SAV1,SAV2,SAV3,
+IP,MINM,KBOUT)
C AUTHOR: RODGER STADEN
C
CHARACTER SEQ1(IDIM1),SEQ2(IDIM2)
INTEGER SAV1(IP),SAV2(IP),SAV3(IP)
C
IP1=IP
IP=0
C
C SITUATION 1
NT1=IDIM2-MINM
IES1=MINM-1
ISS2=NT1+1
C
DO 100 I=1,NT1
C
C POINT TO FIRST CHAR-1 OF SEQ2
ISS2=ISS2-1
C POINT TO LAST CHAR SEQ1
IES1=IES1+1
C
N=0
C
DO 200 J=1,IES1
C STORE POINTER
JJ=J
C
C POINT TO SEQ2
K=ISS2+J
C TEST FOR EQUALITY
IF(SEQ1(J).NE.SEQ2(K))GO TO 220
C INCREMENT N
N=N+1
GO TO 200
220 CONTINUE
C TEST FOR SUFFICENTLY LARGE N
IF(N.GE.MINM)CALL SAVIT(N,J,K,IP,SAV1,SAV2,SAV3,IP1)
C TEST FOR OVERFLOW
IF(IP.GT.IP1)GO TO 5000
C RESET N TO ZERO
N=0
200 CONTINUE
C
C GOOD SCORE AT END?
C NEED TO INCREMENT POINTERS AS SAVIT EXPECTS TO BE POINTING AT NEXT
C MISMATCH
JJ=JJ+1
KK=K+1
IF(N.GE.MINM)CALL SAVIT(N,JJ,KK,IP,SAV1,SAV2,SAV3,IP1)
C TEST FOR OVERFLOW
IF(IP.GT.IP1)GO TO 5000
C
100 CONTINUE
C
C
C SITUATION 2
NT2=IDIM1-IDIM2+1
C
DO 300 I=1,NT2
N=0
C
DO 400 J=1,IDIM2
C SAVE POINTER
JJ=J
C
C SET POINTER TO SEQ1
L=I+J-1
IF(SEQ1(L).NE.SEQ2(J))GO TO 420
N=N+1
GO TO 400
420 CONTINUE
IF(N.GE.MINM)CALL SAVIT(N,L,J,IP,SAV1,SAV2,SAV3,IP1)
C TEST FOR OVERFLOW
IF(IP.GT.IP1)GO TO 5000
N=0
400 CONTINUE
LL=L+1
JJ=JJ+1
IF(N.GE.MINM)CALL SAVIT(N,LL,JJ,IP,SAV1,SAV2,SAV3,IP1)
C TEST FOR OVERFLOW
IF(IP.GT.IP1)GO TO 5000
300 CONTINUE
C
C
C SITUATION 3
ISS1=IDIM1-IDIM2
C
DO 500 I=1,NT1
C
C POINT TO FIRST CHAR SEQ1
K=ISS1+I
IES2=IDIM2-I
N=0
C
DO 600 J=1,IES2
C SAVE POINTER
JJ=J
C
C POINT TO SEQ1
L=K+J
IF(SEQ1(L).NE.SEQ2(J))GO TO 620
N=N+1
GO TO 600
620 CONTINUE
IF(N.GE.MINM)CALL SAVIT(N,L,J,IP,SAV1,SAV2,SAV3,IP1)
C TEST FOR OVERFLOW
IF(IP.GT.IP1)GO TO 5000
N=0
600 CONTINUE
C
LL=L+1
JJ=JJ+1
IF(N.GE.MINM)CALL SAVIT(N,LL,JJ,IP,SAV1,SAV2,SAV3,IP1)
C TEST FOR OVERFLOW
IF(IP.GT.IP1)GO TO 5000
500 CONTINUE
C
RETURN
5000 CONTINUE
C OVERFLOW
C
WRITE(KBOUT,1000)IP1
1000 FORMAT(/' TOO MANY MATCHES. LIMIT = ',I6)
RETURN
END
SUBROUTINE ML(PC,PG,L,N,J)
INTEGER PC(N),PG(N),L(N)
DO 10 I = J,N-1
PC(I) = PC(I+1)
PG(I) = PG(I+1)
L(I) = L(I+1)
10 CONTINUE
END
SUBROUTINE MSTLKL(SEQ,IDIM)
C AUTHOR: RODGER STADEN
CHARACTER SEQ(IDIM)
CHARACTER CHARSU
EXTERNAL CHARSU,INDEXS
DO 100 I=1,IDIM
J = INDEXS(SEQ(I),K)
SEQ(I) = CHARSU(J)
100 CONTINUE
END
CHARACTER FUNCTION MUNOTP(IP)
C AUTHOR RODGER STADEN
CHARACTER PUP*26
SAVE PUP
DATA PUP/'CSTPAGNDEQBZHRKMILVFYW-X? '/
MUNOTP = '-'
IF((IP.GT.0).AND.(IP.LT.23))MUNOTP = PUP(IP:IP)
END
INTEGER FUNCTION NCDEP(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,IGEL,
+STRAND,RREG)
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
INTEGER RREG,STRAND
NCDEP = 0
N = 0
I = IGEL
10 CONTINUE
IF(I.NE.0) THEN
IF(RELPG(I).LE.RREG) THEN
IF(SIGN(1,LNGTHG(I)).EQ.STRAND) N = N + 1
I = RNBR(I)
GO TO 10
END IF
END IF
NCDEP = N
END
SUBROUTINE NEWDB(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,KBOUT,
+IDEVF,IDEVR,IDEVW,IDEVN,MAXDB,WGEL,MAXGEL,LINCON,KGEL,IOK)
C AUTHOR: RODGER STADEN
INTEGER RELPG(MAXDB),LNGTHG(MAXDB),LNBR(MAXDB),RNBR(MAXDB)
CHARACTER LINEIN*80,GEL*62,WGEL(MAXGEL),GELNAM*10
EQUIVALENCE (LINEIN(18:18),GEL)
EQUIVALENCE (LINEIN(8:8),GELNAM)
EXTERNAL LTYPE
LINLEN = 80
LINENO=0
C SET LENGTH OF CONTIG
LENCON=0
C SET POSITION OF RIGHTMOST CHAR OF LAST BLOCK
ILASTR=0
C SET NUMBER OF LAST GEL TO START SO WE CAN IDENTIFY RIGHT AND LEFT
C NEIGHBOURS
LASTS=0
C NEED TO WHERE THE LEFT OF EACH BLOCK IS. ASSUME THE FIRST GEL IN A BLOCK
C IS LEVEL WITH THE LEFT EDGE FOR THAT BLOCK (IT SHOULD BE). SO NEED A FLAG
C (IGF)=0 IF FIRST =1 IF NOT, AND A POSITION (ILEFT) TO MARK THE LEFT EDGE
C NEED TO SET LEFT EDGE TO 1 SO LENGTH CALCULATION WORKS FOR FIRST BLOCK
ILEFT=1
10 CONTINUE
C NEED TO ADD LENGTH OF LONGEST LINE IN LAST BLOCK TO CONSENSUS LENGTH
LENCON=LENCON+ILASTR-ILEFT+1
C RESET POSITION OF RIGHTMOST CHAR OF LAST BLOCK
ILASTR=0
C READ LINE OF NOS
READ(IDEVF,1003,END=100)LINEIN
1003 FORMAT(A)
LINENO=LINENO+1
LT = LTYPE(LINEIN,LINLEN,J1,J2,N,MAXDB,KBOUT)
C WRITE(*,*)LINENO,LT
IF(LT.NE.2) GO TO 400
C SET FLAG FOR NEW BLOCK
IGF=0
20 CONTINUE
C
C READ A LINE, COULD BE A GEL OR A CONSENSUS
READ(IDEVF,1003,END=100)LINEIN
LINENO=LINENO+1
LT = LTYPE(LINEIN,LINLEN,J1,J2,N,MAXDB,KBOUT)
C WRITE(*,*)LINENO,LT
IF(LT.EQ.0) GO TO 400
C WHAT SORT OF LINE?
IF(LT.EQ.1) GO TO 400
IF(LT.EQ.4) THEN
IFIRST = J1 - 17
ILAST = J2 - 17
NPOS=ABS(N)
C GEL LINE SO SAVE
C NEED TO FIND THE RIGHTMOST POSITION FOR EACH BLOCK
IF(ILAST.GT.ILASTR)ILASTR=ILAST
C IF FIRST GEL THIS BLOCK SAVE POSITION OF LEFT EDGE
IF(IGF.EQ.0)ILEFT=IFIRST
C SET FLAG FOR NOT FIRST GEL THIS BLOCK
IGF=1
C START OF GEL?
IF(LNGTHG(NPOS).EQ.0)THEN
C YES SO SET RELPG
RELPG(NPOS)=LENCON+IFIRST-ILEFT+1
C LNBR(NPOS)=LASTS
C SET RIGHT NEIGHBOUR OF LAST GEL TO START
C IF(LASTS.NE.0)RNBR(LASTS)=NPOS
LASTS=NPOS
CALL WRITEN(IDEVN,NPOS,GELNAM)
END IF
C COPY NEW SEQUENCE TO DISK
CALL READW(IDEVW,NPOS,WGEL,MAXGEL)
K1=ABS(LNGTHG(NPOS))+1
K2=K1+ILAST-IFIRST
K11=IFIRST-1
C WRITE(*,*)K1,K2,K11
DO 25 I=K1,K2
K11=K11+1
WGEL(I)=GEL(K11:K11)
25 CONTINUE
CALL WRITEW(IDEVW,NPOS,WGEL,MAXGEL)
C UPDATE LENGTH
LNGTHG(NPOS)=SIGN(K2,N)
C GO BACK FOR NEXT LINE (CONSENSUS OR NEW GEL)
GO TO 20
END IF
C SHOULD BE CONSENSUS, CHECK
IF(LT.NE.3) GO TO 400
C READ WHAT SHOULD BE A BLANK LINE
READ(IDEVF,1003,END=100)LINEIN
LINENO=LINENO+1
LT = LTYPE(LINEIN,LINLEN,IFIRST,ILAST,N,MAXDB,KBOUT)
C WRITE(*,*)LINENO,LT
IF(LT.NE.1) GO TO 400
GO TO 10
100 CONTINUE
C CHECK FOR MISSING BLANK AT END OF FILE
IF(LT.NE.1) LENCON=LENCON+ILASTR-ILEFT+1
LNBR(LINCON) = KGEL
CALL MERGE(RELPG,LNGTHG,LNBR,RNBR,LINCON,IDBSIZ)
C ON INPUT LNBR(LINCON) MAY BE WRONG, BUT ON EXIT RNBR IS CORRECT
I = RNBR(LINCON)
300 CONTINUE
C WRITE(*,*)I,RELPG(I),LNGTHG(I),LNBR(I),RNBR(I)
CALL WRITER(IDEVR,I,RELPG(I),LNGTHG(I),LNBR(I),RNBR(I))
J = I
I = LNBR(I)
IF(I.NE.0) GO TO 300
C WRITE CONTIG LINE
I = LINCON
RELPG(I) = LENCON
LNGTHG(I) = 0
LNBR(I) = J
C WRITE(*,*)I,RELPG(I),LNGTHG(I),LNBR(I),RNBR(I)
CALL WRITER(IDEVR,I,RELPG(I),LNGTHG(I),LNBR(I),RNBR(I))
WRITE(KBOUT,1005)
1005 FORMAT(' Finished, no errors found')
C
IOK = 0
RETURN
400 CONTINUE
C ERROR DETECTED, REPORT LINE NUMBER AND STOP
WRITE(KBOUT,5002)LINENO
5002 FORMAT(' Error in line ',I6,' of file. Processing stopped',
+/,' but your database may be corrupted. Revert to a copy')
IOK = 1
RETURN
END
SUBROUTINE PADCOP(SEQG,SEQG2,LG1,MG,L5,IS2,LG2,MAXGEL,IFAIL,
+KBOUT,SEQC,IC1)
C AUTHOR: RODGER STADEN
PARAMETER (NDUBL = 4)
CHARACTER SEQG(MAXGEL),SEQG2(MAXGEL),DUBBL(NDUBL),SEQC(MAXGEL)
SAVE DUBBL
DATA DUBBL/'D','B','V','H'/
JC1 = IC1
C Make seqg2 from seqg placing L5 padding chars before position MG
C which is the start of the next block of identity. Try to put the
C padding either in line with consensus pads, or next to double
C codes. The positions in seqg are LG1 to MG-1. seqg2 needs to be long
C enough to be extended from IS2 to IS2 + L5 -1 + MGM1-LG1 +1
C ie we add L5 pads, plus the chars between and including LG1 and MGM1
IDONE=0
C POINT TO END OF MISMATCH
MGM1=MG-1
C MAY BE NO CHARS TO COPY
IF(MGM1.LT.LG1)GO TO 111
C Next check added 26-2-91
MAXREQ = IS2 + L5 - 1 + MGM1 - LG1 + 1
IF((MGM1.GT.MAXGEL).OR.(MAXREQ.GT.MAXGEL)) THEN
WRITE(KBOUT,1000)
1000 FORMAT(' Matching region too large for routine padcop,',
+ ' alignment aborted')
IFAIL=1
RETURN
END IF
DO 110 J=LG1,MGM1
IF(IDONE.LT.L5) THEN
IF((JC1.GT.0).AND.(JC1.LT.MAXGEL)) THEN
IF(SEQC(JC1).EQ.'*') THEN
IS2 = IS2 + 1
JC1 = JC1 + 1
IDONE = IDONE + 1
GO TO 109
END IF
END IF
DO 108 M=1,NDUBL
IF(SEQG(J).EQ.DUBBL(M)) THEN
IS2 = IS2 + 1
JC1 = JC1 + 1
IDONE = IDONE + 1
GO TO 109
END IF
108 CONTINUE
109 CONTINUE
END IF
SEQG2(IS2) = SEQG(J)
IS2 = IS2 + 1
JC1 = JC1 + 1
110 CONTINUE
111 CONTINUE
C ALL CHARS COPIED. ENOUGH PADDING?
IF(IDONE.LT.L5)IS2=IS2+L5-IDONE
C IS2 SHOULD NOW BE POINTING AT NEXT CHAR
C ZERO LG2 TO SHOW CALLING ROUTINE COPYING DONE
LG2=0
IFAIL=0
END
SUBROUTINE PADRUN(GEL,IFIRST,ILAST,RUN)
CHARACTER PAD,GEL*50,RUN*50
SAVE PAD
DATA PAD/'*'/
C FIND PADS IN THIS GEL
DO 20 I = IFIRST,ILAST
IF(GEL(I:I).EQ.PAD) THEN
C IS IT AT LEAST THE SECOND IN A RUN
IF(RUN(I:I).EQ.PAD) THEN
C FIND THE LEFT END OF THE RUN
JJ = I
1 CONTINUE
IF(JJ.GT.1)THEN
JJ = JJ - 1
IF(RUN(JJ:JJ).EQ.PAD)GO TO 1
END IF
C FOUND LEFT END OF RUN AT JJ, SO MOVE PAD IF NOT ALREADY A PAD
5 CONTINUE
IF(GEL(JJ:JJ).NE.PAD)THEN
C EXCHANGE ELEMENTS
GEL(I:I) = GEL(JJ:JJ)
GEL(JJ:JJ) = PAD
ELSE
C ALREADY A PAD, SO TRY NEXT TO RIGHT
JJ = JJ + 1
IF(JJ.LT.I) GO TO 5
END IF
END IF
END IF
20 CONTINUE
END
SUBROUTINE PCON1(CHAR,CHRSUM)
C AUTHOR RODGER STADEN
C PART OF PROTEIN 'CONSENSUS' CALCULATION
CHARACTER CHAR
INTEGER CHRSUM
INTEGER CTONUM
EXTERNAL CTONUM
K = CTONUM(CHAR)
IF(K.NE.26)THEN
IF(CHRSUM.EQ.0)THEN
CHRSUM = K
ELSE
IF(K.NE.CHRSUM)CHRSUM = -1
END IF
END IF
END
SUBROUTINE PLC(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,LINCON,IGEL,
+NCONTS,MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
INTEGER RELPG(IDBSIZ),LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
YMIN = 0.
YMAX = ISYMAX
XMIN = 0.
LENCON = 0
DO 10 I = IDBSIZ-NCONTS,IDBSIZ-1
LENCON = LENCON + RELPG(I)
10 CONTINUE
XMAX = LENCON
YINC = (YMAX-YMIN)/3.
Y = 0.
XF = XMIN
N = 0
CALL VECTOM
CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
DO 20 I = IDBSIZ-NCONTS,IDBSIZ-1
N = N + 1
XT = XF + RELPG(I)
Y = Y + YINC
CALL LINE(XF,XT,Y,Y,XMAX,XMIN,YMAX,YMIN,
+ MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
IF((IGEL.NE.0).AND.(I.EQ.LINCON)) THEN
XZ = XF + RELPG(IGEL) + ABS(LNGTHG(IGEL))/2
CALL LINE(XZ,XZ,YMAX,YMIN,XMAX,XMIN,YMAX,YMIN,
+ MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
END IF
XF = XT
IF(N.EQ.2) THEN
N = 0
Y = 0.
END IF
20 CONTINUE
CALL VT100M
END
SUBROUTINE PLTC(RELPG,LNGTHG,LNBR,RNBR,
+IDBSIZ,LGEL,LREG,RREG,STRAND,
+MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,YMID,YINC,DEPTH)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
INTEGER RREG,STRAND,DEPTH
XMIN = LREG
XMAX = RREG
YMAX = ISYMAX
YMIN = 0.
I = LGEL
5 CONTINUE
IF(I.NE.0) THEN
IF((RELPG(I)+ABS(LNGTHG(I))-1).LT.LREG) THEN
I = RNBR(I)
GO TO 5
END IF
END IF
N = 0
10 CONTINUE
IF(I.NE.0)THEN
IF(RELPG(I).LE.RREG) THEN
IF(SIGN(1,LNGTHG(I)).EQ.STRAND) THEN
XF = MAX(RELPG(I),LREG)
XT = MIN(ABS(LNGTHG(I))+RELPG(I)-1,RREG)
N = N + 1
IF(N.GT.DEPTH) N = 1
YF = YMID + N * YINC
CALL LINE(XF,XT,YF,YF,XMAX,XMIN,YMAX,YMIN,
+ MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
END IF
I = RNBR(I)
GO TO 10
END IF
END IF
END
SUBROUTINE PLTCON(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,
+MARGL,MARGR,MARGB,
+MARGT,ISXMAX,ISYMAX,LGEL,LREG,RREG,DEPTHP,DEPTHM)
INTEGER DEPTHP,DEPTHM
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
INTEGER RREG,STRAND
C have window size margt starting at margb
C depths depthp, depthm
YMAX = ISYMAX
YMIN = 0.
XMIN = LREG
XMAX = RREG
RINC = YMAX / (DEPTHP + DEPTHM + 2)
RMID =(DEPTHM+1) * RINC
CALL VECTOM
CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
CALL LINE(XMIN,XMAX,RMID,RMID,XMAX,XMIN,YMAX,YMIN,
+MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
CALL TEXT(XMIN,RMID,'*',1,ISIZE,XMAX,XMIN,YMAX,YMIN,
+MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
CALL TEXT(XMAX,RMID,'*',1,ISIZE,XMAX,XMIN,YMAX,YMIN,
+MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
STRAND = 1
YINC = RINC * STRAND
CALL PLTC(RELPG,LNGTHG,LNBR,RNBR,
+IDBSIZ,LGEL,LREG,RREG,STRAND,
+MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,RMID,YINC,DEPTHP)
STRAND = -1
YINC = RINC * STRAND
CALL PLTC(RELPG,LNGTHG,LNBR,RNBR,
+IDBSIZ,LGEL,LREG,RREG,STRAND,
+MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,RMID,YINC,DEPTHM)
CALL VT100M
END
SUBROUTINE PLTQ(SEQ,IDIM2,
+MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
CHARACTER SEQ(IDIM2),T
PARAMETER (Y0 = 0.,
+ YP1 = 1.,
+ YP2 = 2.,
+ YM1 = -1.,
+ YM2 = -2.)
XMIN = 0.
XMAX = IDIM2
YMIN = YM2
YMAX = YP2
CALL VECTOM
CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
CALL LINE(XIN,XMAX,Y0,Y0,XMAX,XMIN,YMAX,YMIN,
+MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
I = 1
10 CONTINUE
XF = I
T = SEQ(I)
20 CONTINUE
IF(SEQ(I).NE.T) THEN
CALL GLEVEL(T,YF,YT,Y0,YP1,YP2,YM1,YM2)
XT = I - 1
CALL LINE(XF,XF,YF,YT,XMAX,XMIN,YMAX,YMIN,
+ MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
CALL LINE(XF,XT,YT,YT,XMAX,XMIN,YMAX,YMIN,
+ MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
CALL LINE(XT,XT,YF,YT,XMAX,XMIN,YMAX,YMIN,
+ MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
GO TO 10
END IF
I = I + 1
IF(I.LT.IDIM2) GO TO 20
CALL GLEVEL(T,YF,YT,Y0,YP1,YP2,YM1,YM2)
XT = I
CALL LINE(XF,XF,YF,YT,XMAX,XMIN,YMAX,YMIN,
+ MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
CALL LINE(XF,XT,YT,YT,XMAX,XMIN,YMAX,YMIN,
+ MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
CALL LINE(XT,XT,YF,YT,XMAX,XMIN,YMAX,YMIN,
+ MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
CALL VT100M
END
SUBROUTINE POSTC(GELNOS,GELSTR,GELEND,LINEIN,IERR,
+KBOUT,IDEVF,MAXDB,GELNO,LINNO,MAXLIN,RELPG,LNGTHG,LNBR,RNBR,
+IDBSIZ,KGEL)
C AUTHOR: RODGER STADEN
CHARACTER LINEIN*(*)
INTEGER GELNOS(MAXDB),GELSTR(MAXDB),GELEND(MAXDB)
INTEGER GELNO(MAXLIN,2),LINNO(MAXLIN,2),IGEL(2)
INTEGER LNBR(MAXDB),RNBR(MAXDB),RELPG(MAXDB),LNGTHG(MAXDB)
EXTERNAL LTYPE
C GELNOS === GEL NUMBERS (UNIQUE)
C GELSTR === GEL START LINES
C GELEND === GEL END LINES
C LINNO === GEL LINE NUMBERS PER STRIP
C IGEL === NUMBER OF GELS PER STRIP
C LINENO === CURRENT LINE NUMBER
C IUNIQ IS NUMBER OF GELS FOUND
C
C PROBLEM IS TO FIND IF THERE ARE LINES OF WORKING VERSIONS MISSING
C WE PROCESS THE DATA IN PAIRS OF BLOCKS OR STRIPS (A BLOCK OR STRIP IS ONE 50
C CHARACTER WIDTH OF THE CONTIG). IF WE FIND ALL THE GELS THAT APPEAR
C IN STRIP B THEN IF THEY WEREN'T PRESENT IN STRIP A THEY MUST START IN
C STRIP B, IF THEY DONT APPEAR IN STRIP C THEY END IN STRIP B.
C STRATEGY IS TO READ THRU FILE AND REMEMBER WHICH GELS APPEAR IN EACH
C STRIP. BY COMPARING THEM WITH THE LAST STRIP WE CAN KNOW WHICH HAVE ENDED
C AND WHICH HAVE STARTED. HENCE WE STORE A LIST OF GELS AND THEIR START AND
C END LINE NUMBERS. USING THIS WE CAN SEE IF THE LIST IS UNIQUE
C SUB CLIST IS SENT THE CURRENT TWO LISTS OF GEL NUMBERS AND FINDS WHICH HAVE
C STARTED AND ENDED AND BUILDS UP A LIST OF UNIQUE GELS AND THEIR START
C AND END LINE NUMBERS
C
LINLEN = 80
IERR=0
JSTRIP=1
LINENO=0
ISTRIP=1
IUNIQ=0
10 CONTINUE
C READ WHAT SHOULD BE A LINE OF NOS
READ(IDEVF,1003,END=100)LINEIN
1003 FORMAT(A)
LINENO=LINENO+1
LT = LTYPE(LINEIN,LINLEN,J1,J2,N,MAXDB,KBOUT)
C IS IT A LINE OF NOS?
IF(LT.NE.2) GO TO 400
C ZERO GEL COUNT FOR THIS STRIP
IGEL(ISTRIP)=0
20 CONTINUE
C READ A LINE, COULD BE 1 GEL, 2 CONSENSUS OR BLANK
READ(IDEVF,1003,END=100)LINEIN
LINENO=LINENO+1
LT = LTYPE(LINEIN,LINLEN,J1,J2,N,MAXDB,KBOUT)
IF(LT.EQ.0) GO TO 400
IF(LT.EQ.1) GO TO 400
IF(LT.EQ.4) THEN
C GEL LINE SO SAVE
C INCREMENT COUNT TO NUMBER OF GEL
IGEL(ISTRIP)=IGEL(ISTRIP)+1
GELNO(IGEL(ISTRIP),ISTRIP)=N
LINNO(IGEL(ISTRIP),ISTRIP)=LINENO
C BO BACK FOR NEXT LINE (CONSENSUS OR NEW GEL)
GO TO 20
END IF
C SHOULD THEN BE A CONSENSUS
IF(LT.NE.3) GO TO 400
C MUST BE CONSENSUS SO PROCESS THIS STRIP
C PROCESS THIS STRIP OF GELS (IGEL OF THEM)
C WHICH GELS ARE NEW? AND WHICH HAVE ENDED
C IF FIRST EVER STRIP DONT DO THIS
IF(JSTRIP.EQ.1)THEN
DO 6 I=1,IGEL(1)
GELNOS(I)=GELNO(I,1)
GELSTR(I)=LINNO(I,1)
6 CONTINUE
JSTRIP=JSTRIP+1
ISTRIP=2
IUNIQ=IGEL(1)
C READ WHAT SHOULD BE A BLANK LINE
READ(IDEVF,1003,END=100)LINEIN
LINENO=LINENO+1
LT = LTYPE(LINEIN,LINLEN,J1,J2,N,MAXDB,KBOUT)
IF(LT.EQ.0) GO TO 400
IF(LT.NE.1)GO TO 400
GO TO 10
END IF
C ORER OF ARGUMENTS DEPENDS ON ISTRIP
IF(ISTRIP.EQ.2)THEN
CALL CLIST(GELNO(1,1),LINNO(1,1),IGEL(1),
+ GELNO(1,2),LINNO(1,2),IGEL(2),
+ GELNOS,GELSTR,GELEND,MAXDB,IUNIQ,KBOUT,IERR)
IF(IERR.NE.0) GO TO 400
ISTRIP=1
C READ WHAT SHOULD BE A BLANK LINE
READ(IDEVF,1003,END=100)LINEIN
LINENO=LINENO+1
LT = LTYPE(LINEIN,LINLEN,J1,J2,N,MAXDB,KBOUT)
IF(LT.EQ.0) GO TO 400
IF(LT.NE.1)GO TO 400
GO TO 10
END IF
IF(ISTRIP.EQ.1)THEN
CALL CLIST(GELNO(1,2),LINNO(1,2),IGEL(2),
+ GELNO(1,1),LINNO(1,1),IGEL(1),
+ GELNOS,GELSTR,GELEND,MAXDB,IUNIQ,KBOUT,IERR)
IF(IERR.NE.0) GO TO 400
ISTRIP=2
READ(IDEVF,1003,END=100)LINEIN
LINENO=LINENO+1
LT = LTYPE(LINEIN,LINLEN,J1,J2,N,MAXDB,KBOUT)
IF(LT.EQ.0) GO TO 400
IF(LT.NE.1)GO TO 400
GO TO 10
END IF
100 CONTINUE
C MAY BE SOME LEFT IN CURRENT STRIP THAT HAVE NOT BEEN ENDED
C BUT ISTRIP WILL JUST HAVE BEEN CHANGED SO CHANGE IT BACK
IF(ISTRIP.EQ.1)THEN
ISTRIP=2
GO TO 101
END IF
ISTRIP=1
101 CONTINUE
DO 110 I=1,IGEL(ISTRIP)
MATCH=INLIST(GELNOS,IUNIQ,GELNO(I,ISTRIP))
IF(MATCH.NE.0)THEN
GELEND(MATCH)=LINNO(I,ISTRIP)
GO TO 110
END IF
C ERROR
WRITE(KBOUT,1300)GELNO(I,ISTRIP)
1300 FORMAT( ' Error: gel number ',I5,
+ ' expected but not found in list')
IERR = 1
GO TO 400
110 CONTINUE
C AS A CHECK: ARE THE UNIQUE GELS UNIQUE?
DO 120 I=2,IUNIQ
KD=IUNIQ-I+1
IN=INLIST(GELNOS(I),KD,GELNOS(I-1))
IF(IN.EQ.0)GO TO 120
IERR=1
WRITE(KBOUT,1006)GELNOS(I-1),GELSTR(I-1),GELSTR(IN)
1006 FORMAT(' Error: gel',I6,' has a line of data missing!'/
+ ' and appears to start on lines',I6,' and',I6)
GO TO 400
120 CONTINUE
IF(IERR.EQ.0)WRITE(KBOUT,1005)
1005 FORMAT(' Successfully checked line order and missing lines')
C WRITE(*,*)(GELNOS(K),K=1,IUNIQ)
KGEL1 = KGEL
KGEL = ABS(GELNOS(1))
C CHECK THAT THE LEFT GEL NUMBER IS UNCHANGED
IF(KGEL1.NE.KGEL) THEN
WRITE(KBOUT,1001)
1001 FORMAT(' Left gel number of edited contig does not agree',/,
+ ' with original, processing aborted')
IERR = 1
RETURN
END IF
LNBR(KGEL) = 0
RELPG(KGEL) = 0
LNGTHG(KGEL) = 0
DO 200 I = 2,IUNIQ
J1 = ABS(GELNOS(I-1))
J2 = ABS(GELNOS(I))
RNBR(J1) = J2
LNBR(J2) = J1
RELPG(J2) = 0
LNGTHG(J2) = 0
200 CONTINUE
RNBR(J2) = 0
IERR = 0
RETURN
400 CONTINUE
C ERROR
WRITE(KBOUT,1007)LINENO
1007 FORMAT(' Error in line',I6,', of file: lines out of order'/,
+' processing stopped')
IERR=1
RETURN
END
SUBROUTINE READN(IDEVN,N,NAME)
CHARACTER NAME*(*)
READ(IDEVN,REC=N)NAME
RETURN
END
SUBROUTINE READR(IDEVR,N,RELPG,LNGTHG,LNBR,RNBR)
INTEGER RELPG,RNBR
READ(IDEVR,REC=N)RELPG,LNGTHG,LNBR,RNBR
RETURN
END
SUBROUTINE READW(IDEVW,N,GEL,MAXGEL)
CHARACTER GEL(MAXGEL)
READ(IDEVW,REC=N)GEL
RETURN
END
SUBROUTINE REMOVL(MATC,MATG,MATL,IP)
C AUTHOR: RODGER STADEN
INTEGER MATC(IP),MATG(IP),MATL(IP)
C
C SET POINTER TO FIRST MATCH
NMTCH=0
10 CONTINUE
C POINT TO NEXT MATCH
NMTCH=NMTCH+1
C SORT MATCHES ON LENGTH
IPP=IP-NMTCH+1
CALL BUBBL3(MATL(NMTCH),MATG(NMTCH),MATC(NMTCH),IPP)
C LOOK FOR END OF POSITIVES
DO 20 I=NMTCH,IP
J=I
20 IF(MATL(I).LT.1)GO TO 30
J=J+1
30 CONTINUE
IP=J-1
C END OF POSITIVES AT IP
IF(NMTCH.GE.IP)RETURN
K1=MATC(NMTCH)
K2=K1+MATL(NMTCH)-1
K3=MATG(NMTCH)
K4=K3+MATL(NMTCH)-1
C POINT TO FIRST MATCH TO TEST
K6=NMTCH+1
DO 200 I=K6,IP
C DO CONSENSUS FIRST
C OVERLAP?
IF(MATC(I).GT.K2)GO TO 100
K5=MATC(I)+MATL(I)-1
IF(K5.LT.K1)GO TO 100
C DOES OVERLAP
C WHICH END
IF(K5.LE.K2)GO TO 80
C LENGTH TO REDUCE MATCH BY IS IDELT
IDELT=K2-MATC(I)+1
C NEW LENGTH
MATL(I)=MATL(I)-IDELT
C MOVE LEFT ENDS
MATC(I)=MATC(I)+IDELT
MATG(I)=MATG(I)+IDELT
GO TO 100
80 CONTINUE
C LENGTH
MATL(I)=K1-MATC(I)
100 CONTINUE
C NOW LOOK FOR OVERLAPS WITH GEL
C OVERLAP?
IF(MATG(I).GT.K4)GO TO 200
K5=MATG(I)+MATL(I)-1
IF(K5.LT.K3)GO TO 200
C DOES OVERLAP
C WHICH END?
IF(K5.LE.K4)GO TO 180
C LENGTH TO REDUCE MATCH BY IS IDELT
IDELT=K4-MATG(I)+1
C NEW LENGTH
MATL(I)=MATL(I)-IDELT
C MOVE LEFT ENDS
MATC(I)=MATC(I)+IDELT
MATG(I)=MATG(I)+IDELT
GO TO 200
180 CONTINUE
C LENGTH
MATL(I)=K3-MATG(I)
200 CONTINUE
GO TO 10
END
C SAVIT
C
SUBROUTINE SAVIT(N,J,K,IP,S1,S2,S3,IP1)
C AUTHOR: RODGER STADEN
INTEGER S1(IP1),S2(IP1),S3(IP1)
C
IP=IP+1
C TEST FOR OVERFLOW
IF(IP.GT.IP1)RETURN
S1(IP)=N
S2(IP)=J-N
S3(IP)=K-N
C
RETURN
END
SUBROUTINE SCRENR(GEL,MAXGEL,STRING,NAME,FILNAM,
+IDEV1,IDEV2,IDEV3,IDEV4,IDEV,KBIN,KBOUT,
+IHELPS,IHELPE,HELPF,IDEVH)
CHARACTER NAME*(*),FILNAM*(*),HELPF*(*)
CHARACTER GEL(MAXGEL),STRING(60)
CALL YESNO(INF,'Use file of file names',
+IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
IF(INF.LT.0) RETURN
IF(INF.EQ.0) THEN
FILNAM = ' '
CALL OPENF1(IDEV1,FILNAM,0,IOK,KBIN,KBOUT,
+ 'File of gel reading names',
+ IHELPS,IHELPE,HELPF,IDEVH)
IF(IOK.NE.0) RETURN
FILNAM = ' '
CALL OPENF1(IDEV2,FILNAM,1,IOK,KBIN,KBOUT,
+ 'File for names of sequences that pass',
+ IHELPS,IHELPE,HELPF,IDEVH)
IF(IOK.NE.0) RETURN
END IF
FILNAM = ' '
CALL OPENF1(IDEV3,FILNAM,0,IOK,KBIN,KBOUT,
+'File name of recognition sequences',
+IHELPS,IHELPE,HELPF,IDEVH)
IF(IOK.NE.0) RETURN
C
JGEL = 0
IGEL = 0
1 CONTINUE
IF(INF.EQ.1) THEN
31 CONTINUE
MN = 0
CALL GTSTR('Gel reading name',' ',NAME,MN,KBOUT,KBIN,INFLAG)
IF(INFLAG.EQ.3) RETURN
IF(INFLAG.EQ.2) RETURN
IF(INFLAG.EQ.1) THEN
CALL HELP2(IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
GO TO 31
END IF
ELSE
READ(IDEV1,1002,END=100)NAME
END IF
1002 FORMAT(A)
JGEL = JGEL + 1
WRITE(IDEV,*)'Processing', JGEL,' in batch'
WRITE(IDEV,1003)NAME
1003 FORMAT(' Gel reading name ',A)
IDIMG=MAXGEL
CALL OPENRS(IDEV4,NAME,IOK,LRECL,2)
IF(IOK.NE.0)THEN
IF(INF.EQ.1) RETURN
WRITE(KBOUT,*)' Error opening gel reading file'
GO TO 1
END IF
CALL ARRFIM(IDEV4,GEL,IDIMG,KBOUT)
CLOSE(UNIT=IDEV4)
2 CONTINUE
IF(IDIMG.LT.1)THEN
WRITE(KBOUT,*)' Gel reading too short to compare'
GO TO 1
END IF
CALL MSTLKL(GEL,IDIMG)
3 CONTINUE
READ(IDEV3,1005,END=6)STRING
1005 FORMAT(60A1)
C FIND LENGTH OF STRING ASSUMING NO SPACES
DO 4 I=1,60
II=I
IF(STRING(I).EQ.' ')GO TO 5
4 CONTINUE
5 CONTINUE
II=II-1
IF(II.GT.0)CALL FIND(GEL,IDIMG,STRING,II,JMATCH)
IF(JMATCH.EQ.0)GO TO 3
C A MATCH
WRITE(IDEV,1007)JMATCH,(STRING(K),K=1,II)
1007 FORMAT(' Match at',I6,' with ',60A1)
REWIND IDEV3
GO TO 1
C NO MATCH SO SAVE
6 CONTINUE
WRITE(IDEV2,1002)NAME
IGEL = IGEL + 1
REWIND IDEV3
GO TO 1
100 CONTINUE
WRITE(KBOUT,*)'Batch finished'
WRITE(KBOUT,*)JGEL,' compared and ',IGEL,' passed'
RETURN
END
SUBROUTINE SCRENV(MAXGEL,
+WORDP,WORDN,LPOWRC,POSNS,GELN,
+SEQ,MAXSEQ,GEL,GELCOP,MATCH,
+LENGTH,
+SAVPS,SAVPG,SAVL,MAXMAT,CENDS,NENDS,MAXCON,CONST,
+KBIN,KBOUT,IDEV1,IDEV2,IDEV3,IDEV4,IDEV,
+IHELPS,IHELPE,HELPF,IDEVH,FILNAM,NAME,IOK)
INTEGER POSNS(MAXSEQ),GELN(MAXGEL),WORDP(LPOWRC),SAVPS(MAXMAT)
INTEGER SAVPG(MAXMAT),SAVL(MAXMAT)
INTEGER WORDN(LPOWRC)
CHARACTER FILNAM*(*),NAME*(*),HELPF*(*)
CHARACTER GELCOP(MAXGEL)
INTEGER CENDS(MAXCON)
INTEGER NENDS(MAXCON)
INTEGER CONST(LENGTH)
CHARACTER SEQ(MAXSEQ),GEL(MAXGEL),MATCH(MAXGEL)
JGEL = 0
IGELS = 0
CALL YESNO(INF,'Use file of file names',
+IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
IF(INF.LT.0) RETURN
IF(INF.EQ.0) THEN
FILNAM = ' '
CALL OPENF1(IDEV1,FILNAM,0,IOK,KBIN,KBOUT,
+ 'File of gel reading names',
+ IHELPS,IHELPE,HELPF,IDEVH)
IF(IOK.NE.0) RETURN
FILNAM = ' '
CALL OPENF1(IDEV2,FILNAM,1,IOK,KBIN,KBOUT,
+ 'File for names of gel readings that pass',
+ IHELPS,IHELPE,HELPF,IDEVH)
IF(IOK.NE.0) RETURN
END IF
FILNAM = ' '
CALL OPENF1(IDEV4,FILNAM,0,IOK,KBIN,KBOUT,
+'File name of vector sequence',
+IHELPS,IHELPE,HELPF,IDEVH)
IF(IOK.NE.0) RETURN
IDIM = MAXSEQ
CALL ARRFIM(IDEV4,SEQ,IDIM,KBOUT)
CLOSE(UNIT=IDEV4)
MN = LENGTH*2
MX = 50
MINMAT = MAX(15,MN)
CALL GETINT(MN,MX,MINMAT,
+'Minimum initial match',
+IVAL,KBIN,KBOUT,
+IHELPS,IHELPE,HELPF,IDEVH,IOK)
IF(IOK.NE.0) RETURN
MINMAT = IVAL
IDCEND=MAXCON
CALL FNDCON(SEQ,IDIM,CENDS,NENDS,IDCEND,MAXCON,KBOUT)
C IS THE VECTOR SEQUENCE IN THE CORRECT FORMAT WITH A TITLE AT THE FRONT?
IF(IDCEND.EQ.0)THEN
CENDS(1) = -19
NENDS(1) = 1
CENDS(2) = IDIM + 1
IDCEND = 1
END IF
C WRITE(KBOUT,9999)
C9999 FORMAT(' VECTOR SEQUENCE REQUIRES A TITLE EG ',
C 1' <---M13MP7.001----->')
C RETURN
C END IF
CALL BUSY(KBOUT)
CALL ENCO(SEQ,IDIM,POSNS,CONST,LENGTH)
CALL ENCONA(POSNS,IDIM,WORDP,WORDN,LPOWRC,LENGTH)
C
1 CONTINUE
IF(INF.EQ.1) THEN
3 CONTINUE
MN = 0
CALL GTSTR('Gel reading name',' ',NAME,MN,KBOUT,KBIN,INFLAG)
IF(INFLAG.EQ.3) RETURN
IF(INFLAG.EQ.2) RETURN
IF(INFLAG.EQ.1) THEN
CALL HELP2(IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
GO TO 3
END IF
ELSE
READ(IDEV1,1002,END=100)NAME
END IF
JGEL = JGEL + 1
WRITE(IDEV,*)'Processing',JGEL,' in batch'
1002 FORMAT(A)
WRITE(IDEV,1003)NAME
1003 FORMAT(' Gel reading name ',A)
IDIMG=MAXGEL
CALL OPENRS(IDEV3,NAME,IOK,LRECL,2)
IF(IOK.NE.0)THEN
IF(INF.EQ.1) RETURN
WRITE(IDEV,*)' Gel reading file not found'
GO TO 1
END IF
CALL ARRFIM(IDEV3,GEL,IDIMG,KBOUT)
CLOSE(UNIT=IDEV3)
C LONG ENOUGH ?
IF(IDIMG.LT.MINMAT)THEN
WRITE(IDEV,*)' Gel reading too short to compare'
GO TO 1
END IF
CALL SQCOPY(GEL,GELCOP,IDIMG)
ISTRAN=1
IMATCH=0
2 CONTINUE
CALL BUSY(KBOUT)
CALL MSTLKL(GEL,IDIMG)
CALL ENCO(GEL,IDIMG,GELN,CONST,LENGTH)
WRITE(IDEV,1009)ISTRAN
1009 FORMAT(' Searching strand',I6)
IDSAV=MAXMAT
CALL CFGEL(GELN,IDIMG,POSNS,IDIM,WORDP,WORDN,LENGTH,LPOWRC,
+SAVPG,SAVPS,SAVL,
+IDSAV,SEQ,GELCOP,MINMAT,IFAIL,KBOUT)
IF(IDSAV.GT.0) THEN
IMATCH=1
CALL DISMAT(SEQ,IDIM,GELCOP,IDIMG,SAVPS,SAVPG,IDSAV,
+ CENDS,NENDS,IDCEND,MAXCON,IDEV,MATCH)
END IF
IF(ISTRAN.EQ.1) THEN
CALL SQREV(GELCOP,IDIMG)
CALL SQCOM(GELCOP,IDIMG)
CALL SQCOPY(GELCOP,GEL,IDIMG)
ISTRAN = 2
GO TO 2
END IF
IF(IMATCH.EQ.0) THEN
WRITE(IDEV2,1010)NAME
IGELS = IGELS + 1
END IF
GO TO 1
1010 FORMAT(A)
100 CONTINUE
WRITE(KBOUT,*)'Batch finished'
WRITE(KBOUT,*)JGEL,' compared and ',IGELS,' passed'
RETURN
END
SUBROUTINE SHIFTC(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDEVR,
+IDBSIZ,IGN,NCONT,DIST)
C AUTHOR: RODGER STADEN
C SHIFTS PART OF A CONTIG FORM GEL IGN TO RIGHT END
C CONTIG LINE NUMBER IF NCONT
INTEGER RELPG(IDBSIZ)
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
INTEGER DIST
I = IGN
10 CONTINUE
IF(I.NE.0)THEN
RELPG(I) = RELPG(I) + DIST
CALL WRITER(IDEVR,I,RELPG(I),LNGTHG(I),LNBR(I),RNBR(I))
I = RNBR(I)
GO TO 10
END IF
C UPDATE CONTIG LENGTH
RELPG(NCONT) = RELPG(NCONT) + DIST
CALL WRITER(IDEVR,NCONT,RELPG(NCONT),LNGTHG(NCONT),
+LNBR(NCONT),RNBR(NCONT))
END
SUBROUTINE SLIDER(SEQ1,IDC,SEQ2,IDIM2,MS1,MS2,MAXPG,MAXPC,MINSLI,
+MATL,MATC,MATG,IP)
C AUTHOR: RODGER STADEN
CHARACTER SEQ1(IDC),SEQ2(IDIM2)
INTEGER MATL(IP),MATC(IP),MATG(IP),P1S,P1,P2
IP1 = IP
IP = 0
C LEFT END S2 RELATIVE S1 - MAX PADS -2 READY FOR LOOP
P1S = MS1 - MS2 - MAXPC - 1
C TRY NSLIDE START POSNS FOR SEQ2
DO 100 I=1,MAXPG+MAXPC+1
C POINT TO SEQ1 START
P1S = P1S + 1
C POINT TO CURRENT SEQ1 POSN
P1 = P1S
N = 0
C COMPARE WHOLE LENGTH OF SEQ2 (IF P1 WITHIN RANGE)
DO 50 J=1,IDIM2
P2 = J
P1 = P1 + 1
IF(P1.LT.1)GO TO 50
C OFF RIGHT END? IF SO MAY HAVE BEEN A MATCH
IF(P1.GT.IDC)GO TO 40
IF(SEQ1(P1).EQ.SEQ2(P2))GO TO 45
40 CONTINUE
IF(N.GE.MINSLI)CALL SAVIT(N,P1,P2,IP,MATL,MATC,MATG,IP1)
N = 0
GO TO 50
45 CONTINUE
N = N + 1
50 CONTINUE
C GOOD SCORE AT END? NEED TO INCREMENT POINTERS FOR SAVIT
P1 = P1 + 1
P2 = P2 + 1
IF(N.GE.MINSLI)CALL SAVIT(N,P1,P2,IP,MATL,MATC,MATG,IP1)
100 CONTINUE
END
SUBROUTINE SUBS(SEQ,IDIMS,FROM,TO)
CHARACTER SEQ(IDIMS),FROM,TO
C AUTHOR RODGER STADEN
DO 10 I = 1,IDIMS
IF(SEQ(I).EQ.FROM) SEQ(I) = TO
10 CONTINUE
END
SUBROUTINE SUMMAR(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
+SEQ1,IDIM1,GEL,LREG,RREG,IGELC,PERCD,IDBSIZ,CHARS,
+ID1,CHRSIZ,MAXGL2,IDEVW,MAXGEL,LINOU1,LINOU2,MXGOOD)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ),CHRSIZ
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
CHARACTER SEQ1(IDIM1)
CHARACTER GEL(MAXGEL)
INTEGER LREG,RREG,LSEQNO,POSN,Y,POSN1
INTEGER GELC
CHARACTER LINOU1(MAXGEL),LINOU2(MAXGEL),GTCONC
INTEGER CHARS(CHRSIZ,ID1,MAXGL2)
EXTERNAL INDEXS,LWRAPS,GTCONC
C 28-7-91 added extra parameter: mxgood is the maximum reading
C length for which we have confidence, so only the parts of
C reads 1 to mxgood will be included in the calculation
C SET INITIAL VALUES
C hard to understand this very old code! rewrite it.
C we have a summing array of twice the length of the longest sequence
C posn is posn in contig of next to write, lseqno is current posn in contig
C we write when lseqno-posn ge the length of the longest seq
POSN=LREG
GELC=IGELC
LINLEN=MAXGEL
LSEQNO=RELPG(GELC)
IEND=0
DO 40 I=1,MAXGL2
DO 40 J=1,ID1
DO 40 K=1,CHRSIZ
CHARS(K,J,I)=0
40 CONTINUE
50 CONTINUE
ISS=1
IF(LNGTHG(GELC).LT.0)ISS=2
CALL READW(IDEVW,GELC,GEL,MAXGEL)
C LOOP FOR RELEVANT ELEMENTS THIS GEL
C only use mxgood characters from start of read
C
IF(ISS.EQ.1) THEN
N = MIN(MXGOOD,ABS(LNGTHG(GELC)))
IF(LSEQNO.LT.LREG)LSEQNO=LREG
IS = LSEQNO-RELPG(GELC)+1
ELSE
C LOOP FOR RELEVANT ELEMENTS THIS GEL
C only use mxgood characters from start of read (right end for these)
C
IREND = RELPG(GELC) - LNGTHG(GELC) + 1
IF (MXGOOD.LT.MAXGEL) THEN
LSEQNO = IREND - MXGOOD + 1
ELSE
LSEQNO = RELPG(GELC)
END IF
LSEQNO = MAX(LSEQNO,LREG)
IS = LSEQNO - RELPG(GELC) + 1
N = ABS(LNGTHG(GELC))
END IF
DO 70 I=IS,N
JJ = INDEXS(GEL(I),JSCORE)
JJJ = LWRAPS(LSEQNO,MAXGL2)
CHARS(JJ,ISS,JJJ) = CHARS(JJ,ISS,JJJ) + JSCORE
LSEQNO = LSEQNO + 1
70 CONTINUE
IF(RNBR(GELC).EQ.0)GO TO 200
GELC=RNBR(GELC)
LSEQNO=RELPG(GELC)
IF(LSEQNO.GT.RREG)GO TO 200
C ENOUGH TO OUTPUT?
Y=LSEQNO-POSN
IF(Y.GE.MAXGEL)GO TO 210
GO TO 50
200 CONTINUE
C SET FLAG TO SHOW END REACHED
IEND=1
LINLEN=MAXGEL
Y=RREG-POSN
IF(Y.LT.MAXGEL)LINLEN=Y+1
210 CONTINUE
C SET POINTER TO SEQ1
POSN1=POSN-1
C PREPARE NEXT SECTION OF CHARS FOR OUTPUT
DO 230 I=1,LINLEN
JJJ = LWRAPS(POSN,MAXGL2)
LINOU1(I) = GTCONC(CHARS(1,1,JJJ),CHRSIZ,PERCD)
LINOU2(I) = GTCONC(CHARS(1,2,JJJ),CHRSIZ,PERCD)
DO 250 J=1,CHRSIZ
CHARS(J,1,JJJ)=0
CHARS(J,2,JJJ)=0
250 CONTINUE
POSN=POSN+1
230 CONTINUE
C
C COMPARE STRANDS
C
DO 500 I=1,LINLEN
C WRITE(*,*)I,LINOU1(I),LINOU2(I)
POSN1=POSN1+1
IF(LINOU1(I).EQ.LINOU2(I)) THEN
IF(LINOU1(I).EQ.'-') THEN
SEQ1(POSN1) = '3'
GO TO 500
END IF
IF(LINOU1(I).EQ.'*') THEN
SEQ1(POSN1) = '3'
GO TO 500
END IF
SEQ1(POSN1) = '0'
ELSE
IF((LINOU1(I).EQ.'*').AND.(LINOU2(I).EQ.'-')) THEN
SEQ1(POSN1) = '3'
GO TO 500
END IF
IF((LINOU2(I).EQ.'*').AND.(LINOU1(I).EQ.'-')) THEN
SEQ1(POSN1) = '3'
GO TO 500
END IF
IF((LINOU1(I).NE.'-').AND.(LINOU1(I).NE.'*')) THEN
SEQ1(POSN1) = '1'
IF((LINOU2(I).NE.'-').AND.(LINOU2(I).NE.'*'))
+ SEQ1(POSN1) = '4'
GO TO 500
END IF
IF((LINOU2(I).NE.'-').AND.(LINOU2(I).NE.'*')) THEN
SEQ1(POSN1) = '2'
IF((LINOU1(I).NE.'-').AND.(LINOU1(I).NE.'*'))
+ SEQ1(POSN1) = '4'
GO TO 500
END IF
END IF
500 CONTINUE
IF(POSN.GT.RREG)RETURN
IF((IEND.EQ.1).AND.(POSN.LE.RREG))GO TO 200
C ANY MORE MAXGEL CHAR LENGTHS TO OUTPUT
Y=LSEQNO-POSN
IF(Y.LT.MAXGEL)GO TO 50
C FINISHED COMPLETELY?
GO TO 210
END
C SUMMER
C
C SUBROUTINE TO PRODUCE A CONSENSUS FROM LINED UP GEL READINGS
SUBROUTINE SUMMER(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
1SEQ1,IDIM1,GEL,LREG,RREG,IGELC,IDBSIZ,CHARS,CHRSIZ,MAXGL2,
+IDEVW,MAXGEL,IDM,PERCD)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ),CHRSIZ
INTEGER LREG,RREG,LSEQNO,POSN,Y
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
CHARACTER GEL(MAXGEL)
INTEGER GELC
CHARACTER SEQ1(IDIM1)
INTEGER CHARS(CHRSIZ,MAXGL2)
CHARACTER MUNOTP,GTCONC
EXTERNAL MUNOTP,INDEXS,GTCONC,LWRAPS
C
C SET INITIAL VALUES
POSN=LREG
GELC=IGELC
LINLEN=MAXGEL
LSEQNO=RELPG(GELC)
IEND=0
IPSEQ1=0
C
C ZERO ARRAY
DO 40 I=1,MAXGL2
DO 40 J=1,CHRSIZ
CHARS(J,I)=0
40 CONTINUE
50 CONTINUE
CALL READW(IDEVW,GELC,GEL,MAXGEL)
C LOOP FOR RELEVANT ELEMENTS THIS GEL
N=ABS(LNGTHG(GELC))
IF(LSEQNO.LT.LREG)LSEQNO=LREG
IS=(LSEQNO-RELPG(GELC))+1
****************************
IF(IDM.EQ.26)THEN
DO 51 I = IS,N
JJJ=(MOD(LSEQNO,MAXGL2))
IF(JJJ.EQ.0)JJJ=MAXGL2
CALL PCON1(GEL(I),CHARS(1,JJJ))
LSEQNO = LSEQNO + 1
51 CONTINUE
ELSE
****************************
DO 70 I=IS,N
JJ = INDEXS(GEL(I),JSCORE)
JJJ = LWRAPS(LSEQNO,MAXGL2)
CHARS(JJ,JJJ) = CHARS(JJ,JJJ) + JSCORE
LSEQNO = LSEQNO + 1
70 CONTINUE
END IF
C
C LOOK AT NEXT GEL TO RIGHT
IF(RNBR(GELC).EQ.0)GO TO 200
GELC=RNBR(GELC)
C RESET LSEQNO
LSEQNO=RELPG(GELC)
C IS THIS OVER END?
IF(LSEQNO.GT.RREG)GO TO 200
C ENOUGH TO OUTPUT?
Y=LSEQNO-POSN
IF(Y.GE.MAXGEL)GO TO 210
GO TO 50
200 CONTINUE
C SET FLAG TO SHOW END REACHED
IEND=1
C NEED TO SUM AND OUTPUT
LINLEN=MAXGEL
Y=RREG-POSN
IF(Y.LT.MAXGEL)LINLEN=Y+1
210 CONTINUE
C SUM NEXT SECTION OF CHARS
IF(IDM.EQ.26)THEN
DO 211 I = 1,LINLEN
IPSEQ1 = IPSEQ1 + 1
SEQ1(IPSEQ1) = '-'
JJJ = MOD(POSN,MAXGL2)
IF(JJJ.EQ.0)JJJ = MAXGL2
SEQ1(IPSEQ1) = MUNOTP(CHARS(1,JJJ))
CHARS(1,JJJ) = 0
POSN = POSN + 1
211 CONTINUE
ELSE
DO 230 I=1,LINLEN
IPSEQ1=IPSEQ1+1
ISUM=0
JJJ = LWRAPS(POSN,MAXGL2)
SEQ1(IPSEQ1) = GTCONC(CHARS(1,JJJ),CHRSIZ,PERCD)
CALL FILLI(CHARS(1,JJJ),CHRSIZ,0)
POSN = POSN + 1
230 CONTINUE
END IF
C
C
C ANY MORE TO OUTPUT?
IF(POSN.GT.RREG)RETURN
IF((IEND.EQ.1).AND.(POSN.LE.RREG))GO TO 200
C ANY MORE MAXGLEL CHAR LENGTHS TO OUTPUT
Y=LSEQNO-POSN
IF(Y.LT.MAXGEL)GO TO 50
C FINISHED COMPLETELY?
GO TO 210
END
SUBROUTINE TPCHEK(PC,PG,L,N)
INTEGER PC(N),PG(N),L(N)
C AUTHOR RODGER STADEN
C IF OVERLAPPING BLOCKS ARE FOUND REMOVE THE SHORTER ONE
C THEN REMOVE LARGE GAPS AT ENDS (THOSE AS LARGE AS THE END BLOCK)
K1 = 2
1 CONTINUE
DO 10 I = K1,N
J1 = I
IF(PC(I).LE.PC(I-1)) GO TO 20
IF(PG(I).LE.PG(I-1)) GO TO 20
10 CONTINUE
C REMOVE LARGE GAPS FROM ENDS
C THIS RULE OF THUMB COULD BE CHANGED TO USE A DIFFERENCE
C BETWEEN THE NUMBERS OF MISMATCHING CHARACTERS
IF(N.GT.1) THEN
K1 = PC(2) - PC(1) - L(1)
J1 = PG(2) - PG(1) - L(1)
IF(MAX(K1,J1).GT.L(1)) THEN
CALL ML(PC,PG,L,N,1)
N = N - 1
END IF
IF(N.GT.1) THEN
K1 = PC(N) - PC(N-1) - L(N-1)
J1 = PG(N) - PG(N-1) - L(N-1)
IF(MAX(K1,J1).GT.L(N)) THEN
CALL ML(PC,PG,L,N,N)
N = N - 1
END IF
END IF
END IF
RETURN
20 CONTINUE
IF(L(J1-1).GT.L(J1)) THEN
CALL ML(PC,PG,L,N,J1)
ELSE
CALL ML(PC,PG,L,N,J1-1)
END IF
C Until 25-11-90 next line was k1=j1 but this does not deal with all
C cases: when a line is deleted we must compare it with the previous
C one before dealing with the rest, because it could be left of that
C one as well!
K1 = MAX(2,J1-1)
N = N - 1
GO TO 1
END
SUBROUTINE WRITEN(IDEVN,N,NAME)
CHARACTER NAME*(*)
WRITE(IDEVN,REC=N)NAME
RETURN
END
SUBROUTINE WRITER(IDEVR,N,RELPG,LNGTHG,LNBR,RNBR)
INTEGER RELPG,RNBR
WRITE(IDEVR,REC=N)RELPG,LNGTHG,LNBR,RNBR
RETURN
END
SUBROUTINE WRITEW(IDEVW,N,GEL,MAXGEL)
CHARACTER GEL(MAXGEL)
WRITE(IDEVW,REC=N)GEL
RETURN
END
SUBROUTINE XHSAP(RELPG,LNGTHG,LNBR,RNBR,
+IDBSIZ,NCONTS,LLINOI,LINCNI,LREG,RREG,
+WINDOW,GWIND,LENCON,DEPTHP,DEPTHM,
+MARGL,MARGR,MARGB,MARGT,MAXOPT,ISXMAX,ISYMAX,KBIN,IDEV,
+KBOUT,GEL,GEL2,IDEV2,IDEV3,LINLEN,PERCD,MAXGEL,IDM,
+SEQ1,IDIM1,NGELS,TEMP3,CHRSIZ,MAXGL2,LINOU1,LINOU2,
+NOPT1,NOPT2,NOPT3,
+IHELPS,IHELPE,HELPF,IDEVH,MXGOOD)
C AUTHOR: RODGER STADEN
INTEGER RELPG(IDBSIZ),WINDOW,CHRSIZ,GWIND
INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
INTEGER MARGB(MAXOPT),MARGT(MAXOPT)
INTEGER RREG,DEPTHP,DEPTHM,STRAND,CHNRP1,HQN
INTEGER TEMP3(2,CHRSIZ,MAXGL2)
CHARACTER GEL(MAXGEL),GEL2(MAXGEL)
CHARACTER TERM,TUPPER,NAMARC*10,HELPF*(*)
CHARACTER SEQ1(IDIM1),LINOU1(MAXGEL),LINOU2(MAXGEL)
EXTERNAL NOPWIN,CWORLD,TUPPER,CHNRP1,HQN
C nopt1 = single contig
C nopt2 = all contigs
C nopt3 = scan
10 CONTINUE
LLINO = LLINOI
LINCON = LINCNI
LOCLR = 0
LOCRR = 0
CALL BPAUSE(KBIN,KBOUT,IOK)
CALL CLEARV
CALL XHAIRR(ISXMAX,ISYMAX,IX,IY,TERM,DBTDUX,DBTDUY)
CALL VT100M
INFLAG = HQN(TERM)
IF(INFLAG.EQ.1) THEN
CALL HELP2(IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
GO TO 10
END IF
IF(INFLAG.EQ.2) RETURN
IF(INFLAG.EQ.3) RETURN
NOPT = NOPWIN(IY,MARGB,MARGT,MAXOPT)
TERM = TUPPER(TERM)
IF(NOPT.EQ.0) RETURN
IF(NOPT.EQ.NOPT3) THEN
IF(TERM.EQ.'S') THEN
XMIN = LREG
XMAX = RREG
X = CWORLD(IX,MARGL,MARGR,XMIN,XMAX)
LOCLR = MAX(LREG,NINT(X)-WINDOW)
LOCRR = MIN(RREG,NINT(X)+WINDOW-1)
IF(LOCLR.NE.0) THEN
CALL DSPLAY(RELPG,LNGTHG,LNBR,RNBR,
+ GEL,LLINO,LINCON,LOCLR,LOCRR,GEL2,I1,I2,0,I,
+ IDBSIZ,IDEV,KBOUT,
+ IDEV2,IDEV3,LINLEN,PERCD,MAXGEL,IDM)
GO TO 10
END IF
END IF
IF((TERM.EQ.'N').OR.(TERM.EQ.'Z').OR.(TERM.EQ.'I')) GO TO 10
END IF
IF(NOPT.EQ.NOPT1) THEN
STRAND = 1
CALL FDPTH(RELPG,LNGTHG,LNBR,RNBR,
+ IDBSIZ,LLINO,LREG,RREG,LENCON,STRAND,DEPTHP)
IF(DEPTHP.LT.0) RETURN
STRAND = -1
CALL FDPTH(RELPG,LNGTHG,LNBR,RNBR,
+ IDBSIZ,LLINO,LREG,RREG,LENCON,STRAND,DEPTHM)
IF(DEPTHM.LT.0) RETURN
YMAX = ISYMAX
YMIN = 0.
XMIN = LREG
XMAX = RREG
RINC = ISYMAX / (DEPTHP + DEPTHM + 2)
RMID =(DEPTHM+1) * RINC
X = CWORLD(IX,MARGL,MARGR,XMIN,XMAX)
Y = CWORLD(IY,MARGB(NOPT),MARGT(NOPT),YMIN,YMAX)
IF(TERM.EQ.'I') THEN
STRAND = 1
YINC = RINC * STRAND
CALL IPLTC(RELPG,LNGTHG,LNBR,RNBR,
+ IDBSIZ,LLINO,LREG,RREG,STRAND,
+ MARGL,MARGR,MARGB(NOPT),MARGT(NOPT),
+ ISXMAX,ISYMAX,RMID,YINC,DEPTHP,X,Y,
+ KBOUT,IGEL,ICLOSE)
IF(ICLOSE.EQ.1) THEN
STRAND = -1
YINC = RINC * STRAND
CALL IPLTC(RELPG,LNGTHG,LNBR,RNBR,
+ IDBSIZ,LLINO,LREG,RREG,STRAND,
+ MARGL,MARGR,MARGB(NOPT),MARGT(NOPT),
+ ISXMAX,ISYMAX,RMID,YINC,DEPTHM,X,Y,
+ KBOUT,IGEL,ICLOSE)
END IF
IF(ICLOSE.EQ.1) GO TO 10
CALL READN(IDEV3,IGEL,NAMARC)
WRITE(IDEV,1006)NAMARC,IGEL,RELPG(IGEL),LNGTHG(IGEL)
1006 FORMAT
+ ( ' Name ',A,' Number ',I4,' Rel. Posn. ',I7,' Length ',I5)
GO TO 10
END IF
IF(TERM.EQ.'Z') THEN
STRAND = 1
YINC = RINC * STRAND
CALL IPLTC(RELPG,LNGTHG,LNBR,RNBR,
+ IDBSIZ,LLINO,LREG,RREG,STRAND,
+ MARGL,MARGR,MARGB(NOPT),MARGT(NOPT),
+ ISXMAX,ISYMAX,RMID,YINC,DEPTHP,X,Y,
+ KBOUT,IGEL,ICLOSE)
IF(ICLOSE.EQ.1) THEN
STRAND = -1
YINC = RINC * STRAND
CALL IPLTC(RELPG,LNGTHG,LNBR,RNBR,
+ IDBSIZ,LLINO,LREG,RREG,STRAND,
+ MARGL,MARGR,MARGB(NOPT),MARGT(NOPT),
+ ISXMAX,ISYMAX,RMID,YINC,DEPTHM,X,Y,
+ KBOUT,IGEL,ICLOSE)
END IF
IF(IGEL.EQ.0) GO TO 10
CALL CLEARG
CALL PLC(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,LINCON,IGEL,
+ NCONTS,MARGL,MARGR,MARGB(NOPT2),MARGT(NOPT2),ISXMAX,ISYMAX)
LREG = MAX(1,RELPG(IGEL)-GWIND)
RREG = MIN(RELPG(LINCON),RELPG(IGEL)+GWIND)
LLINO = LNBR(LINCON)
LLINOI = LLINO
LINCNI = LINCON
LENCON = RREG - LREG + 1
CALL FDEPTH(RELPG,LNGTHG,LNBR,RNBR,
+ IDBSIZ,LLINO,LREG,RREG,LENCON,
+ MARGL,MARGR,MARGB(NOPT1),MARGT(NOPT1),ISXMAX,ISYMAX)
GO TO 10
END IF
IF(TERM.EQ.'S') THEN
LOCLR = MAX(LREG,NINT(X)-WINDOW)
LOCRR = MIN(RREG,NINT(X)+WINDOW-1)
IF(LOCLR.NE.0) THEN
CALL DSPLAY(RELPG,LNGTHG,LNBR,RNBR,
+ GEL,LLINO,LINCON,LOCLR,LOCRR,GEL2,I1,I2,0,I,
+ IDBSIZ,IDEV,KBOUT,
+ IDEV2,IDEV3,LINLEN,PERCD,MAXGEL,IDM)
GO TO 10
END IF
END IF
IF(TERM.EQ.'N') THEN
LOCLR = MAX(LREG,NINT(X)-WINDOW)
LOCRR = MIN(RREG,NINT(X)+WINDOW-1)
IGEL = CHNRP1(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,
+ LLINO,LREG)
IF(LOCLR.NE.0) THEN
CALL LSTCON(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,IGEL,
+ LOCRR,IDEV,IDEV3,NAMARC)
END IF
GO TO 10
END IF
IF(TERM.EQ.'Q') THEN
CALL DBSCNP(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,SEQ1,
+ IDIM1,GEL,IDBSIZ,TEMP3,2,CHRSIZ,MAXGL2,IDEV2,LLINO,
+ PERCD,MAXGEL,LINOU1,LINOU2,LREG,RREG,
+ MARGL,MARGR,MARGB(NOPT3),MARGT(NOPT3),ISXMAX,ISYMAX,
+ MXGOOD)
GO TO 10
END IF
END IF
IF(NOPT.EQ.NOPT2) THEN
CALL IDPLC(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,
+ NCONTS,IX,IY,MARGL,MARGR,MARGB(NOPT),MARGT(NOPT),
+ ISXMAX,ISYMAX,DBTDUX,DBTDUY,
+ LINCON,IGEL,IS)
IF(IGEL.EQ.0) RETURN
IF(TERM.EQ.'Z') THEN
CALL CLEARG
CALL PLC(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,LINCON,IGEL,
+ NCONTS,MARGL,MARGR,MARGB(NOPT),MARGT(NOPT),ISXMAX,ISYMAX)
LREG = 1
RREG = RELPG(LINCON)
LLINO = LNBR(LINCON)
LLINOI = LLINO
LINCNI = LINCON
LENCON = RREG - LREG + 1
CALL FDEPTH(RELPG,LNGTHG,LNBR,RNBR,
+ IDBSIZ,LLINO,LREG,RREG,LENCON,
+ MARGL,MARGR,MARGB(NOPT1),MARGT(NOPT1),ISXMAX,ISYMAX)
GO TO 10
END IF
IF(TERM.EQ.'Q') THEN
CALL CLEARG
CALL PLC(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,LINCON,IGEL,
+ NCONTS,MARGL,MARGR,MARGB(NOPT),MARGT(NOPT),ISXMAX,ISYMAX)
LREG = 1
RREG = RELPG(LINCON)
LLINO = LNBR(LINCON)
LLINOI = LLINO
LINCNI = LINCON
LENCON = RREG - LREG + 1
CALL FDEPTH(RELPG,LNGTHG,LNBR,RNBR,
+ IDBSIZ,LLINO,LREG,RREG,LENCON,
+ MARGL,MARGR,MARGB(NOPT1),MARGT(NOPT1),ISXMAX,ISYMAX)
CALL DBSCNP(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,SEQ1,
+ IDIM1,GEL,IDBSIZ,TEMP3,2,CHRSIZ,MAXGL2,IDEV2,LLINO,
+ PERCD,MAXGEL,LINOU1,LINOU2,LREG,RREG,
+ MARGL,MARGR,MARGB(NOPT3),MARGT(NOPT3),ISXMAX,ISYMAX,
+ MXGOOD)
GO TO 10
END IF
IF(TERM.EQ.'I') THEN
CALL READN(IDEV3,IGEL,NAMARC)
WRITE(IDEV,1006)NAMARC,IGEL,RELPG(IGEL),LNGTHG(IGEL)
GO TO 10
END IF
IF(TERM.EQ.'S') THEN
LOCLR = MAX(1,IS-WINDOW)
LOCRR = MIN(RELPG(LINCON),IS+WINDOW-1)
LLINO = LNBR(LINCON)
IF(LOCLR.NE.0) THEN
CALL DSPLAY(RELPG,LNGTHG,LNBR,RNBR,
+ GEL,LLINO,LINCON,LOCLR,LOCRR,GEL2,I1,I2,0,I,
+ IDBSIZ,IDEV,KBOUT,
+ IDEV2,IDEV3,LINLEN,PERCD,MAXGEL,IDM)
END IF
GO TO 10
END IF
IF(TERM.EQ.'N') THEN
LOCLR = MAX(1,IS-WINDOW)
LOCRR = MIN(RELPG(LINCON),IS+WINDOW-1)
LLINO = LNBR(LINCON)
IF(LOCLR.NE.0) THEN
CALL LSTCON(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,IGEL,
+ LOCRR,IDEV,IDEV3,NAMARC)
END IF
GO TO 10
END IF
END IF
END
INTEGER FUNCTION CLINNO(LNBR,IDBSIZ,NCONTS,IIN)
C AUTHOR: RODGER STADEN
C RETURNS CONTIG LINE NUMBER OR ZERO FOR ERROR
INTEGER LNBR(IDBSIZ)
CLINNO = 0
N=IDBSIZ-NCONTS
DO 10 J=N,IDBSIZ-1
IF(LNBR(J).EQ.IIN) THEN
CLINNO = J
RETURN
END IF
10 CONTINUE
END
Reference in New Issue View Git Blame Copy Permalink