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
