C 26-1-93 added new consensus routine
C  added file busy check
C  9-7-92  Changed remove contig line to remove all readings as well
C   4-6-92 Added pad shifting routine
C   6-4-92 fixed a bug in autocn revealed by new update method:
C          for some cases where more than 2 overlaps were being found
C          i was moving the wrong arrays around!
C   2-4-92 added new dbauto with new update consensus method
C          and new consensus calculation
C   2-4-92 brought uptodate with dap
C   29.05.91  IMPLEMENTED  REMOVE GEL READING
C   21-8-91 Added routines to find internal overlaps
C    2-9-91 Fixed bug in copytg
C   8-11-91 fixed bugs in "find internal joins"
C   23-Jun-92 COPYTAG - params to READCC and WRITCC in wrong order
C
      SUBROUTINE NEWCON(RELPG,LNGTHG,LNBR,RNBR,MAXDB,IDBSIZ,
     +NGELS,NCONTS,MAXGEL,LLINO,LINCON,KOPT,
     +TEMP3,SEQ1,MAXSEQ,SEQ2,SEQ3,
     +MAXGLM,MAXGL2,CHRSIZ,ECHRSZ,
     +ILADD,IRADD,MAXCON,
     +KBIN,KBOUT,IDEV1,IDEV2,IDEV3,IDEV,
     +IHELPS,IHELPE,HELPF,IDEVH,NAMARC,NAMPRO,FILE,
     +PERCD,IDM,IDEVC,IDEVT)
      INTEGER CHRSIZ,ECHRSZ,RREG
      INTEGER RELPG(MAXDB)
      INTEGER LNGTHG(MAXDB),LNBR(MAXDB),RNBR(MAXDB)
      INTEGER TEMP3(ECHRSZ,MAXGL2),ANS
      INTEGER ILADD(MAXCON),IRADD(MAXCON)
      CHARACTER SEQ3(MAXGLM)
      CHARACTER SEQ1(MAXSEQ),SEQ2(MAXGLM)
      CHARACTER NAMARC*(*),NAMPRO*(*),FILE*(*),HELPF*(*)
      PARAMETER (MAXPRM = 6)
      CHARACTER PROMPT(2)*(MAXPRM)
      IF(NGELS.LT.1) RETURN
      CALL DBCHEK(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +  TEMP3,IERR,KBOUT)
      IF(IERR.GT.1) RETURN
      PROMPT(1) = 'Staden'
      PROMPT(2) = 'FASTA'
C
C idim is current consensus length
C
      IDIM = 0
      ANS = 0
      IWING = 0
      FILE = ' '
      CALL OPENF1(IDEV,FILE,1,IOK,KBIN,KBOUT,
     +'Name for consensus file',
     +IHELPS,IHELPE,FILEH,IDEVH)
      IF(IOK.NE.0)RETURN
      IF (KOPT.EQ.1) THEN
       CALL YESNO(I,'Use clipped data',
     +  IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
       IF(I.LT.0) GO TO 400
       IF(I.EQ.0) THEN
         MN = 1
         MX = MAXGEL
         IWING = 100
         CALL GETINT(MN,MX,IWING,
     +   'Window size for good data scan',
     +   IVAL,KBIN,KBOUT,
     +   IHELPS,IHELPE,HELPF,IDEVH,IOK)
         IF(IOK.NE.0) GO TO 400
         IWING = IVAL
         MN = 1
         MX = MIN(100,IWING)
         NBAD = MIN(IWING,5)
         CALL GETINT(MN,MX,NBAD,
     +   'Maximum number of dashes in scan window',
     +   IVAL,KBIN,KBOUT,
     +   IHELPS,IHELPE,HELPF,IDEVH,IOK)
         IF(IOK.NE.0) GO TO 400
         NBAD = IVAL
       END IF
      END IF
      CALL YESNO(ANS,'Make consensus for whole database',
     +IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
      IF(ANS.LT.0) GO TO 400
      IF(ANS.EQ.1)GO TO 150
      IDIM2=MAXGEL
C
C calc the consensus and add the unused data if required
C save the lengths of the unused data in iladd, iradd
C (we dont use them here!)
C
      CALL FILLI(ILADD,NCONTS,0)
      CALL FILLI(IRADD,NCONTS,0)
      JOB = 0
      CALL JCONS(RELPG,LNGTHG,LNBR,RNBR,NAMPRO,NGELS,NCONTS,
     +SEQ1,MAXSEQ,SEQ2,IDBSIZ,IDIM,JOB,KDUMM,KDUMM,KDUMM,KDUMM,
     +TEMP3,
     +ECHRSZ,MAXGL2,KBOUT,IDEV2,IFAIL,MAXGEL,IDM,PERCD,SEQ3,
     +ILADD,IRADD,MAXCON,KDUMM,IWING,NBAD)
      IF(IFAIL.NE.0) GO TO 400
      ANS = 1
      CALL RADION('Select output format',PROMPT,2,ANS,
     +IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
      IF (ANS.LT.1) GO TO 400
      IF(ANS.EQ.1) THEN
        CALL FMTDK(IDEV,SEQ1,IDIM)
      ELSE
        CALL WRITCF(IDEV,SEQ1,IDIM,NAMPRO,KBOUT,IOK)
      END IF
      RETURN
150   CONTINUE
      CALL GETLN3(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +LINCON,LLINO,NULGEL,IERR,IDBSIZ,KBIN,KBOUT,IDEV3,
     +'Contig identifier',
     +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((IDIM+20+IDIM2).GT.MAXSEQ)THEN
         CALL ERROM(KBOUT,'Maximum consensus length exceeded')
         CLOSE(UNIT=IDEV)
         RETURN
      END IF
      JOB = 1
      JCON = 1
      CALL JCONS(RELPG,LNGTHG,LNBR,RNBR,NAMPRO,NGELS,NCONTS,
     +    SEQ1,MAXSEQ,SEQ2,IDBSIZ,IDIM,JOB,LLINO,LINCON,LREG,RREG,
     +    TEMP3,
     +    ECHRSZ,MAXGL2,KBOUT,IDEV2,IFAIL,MAXGEL,IDM,PERCD,SEQ3,
     +    ILADD,IRADD,MAXCON,JCON,IWING,NBAD)
      IF (IFAIL.NE.0) GO TO 400
300   CONTINUE
      CALL YESNO(ANS,'Select another contig',
     +IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
      IF(ANS.LT.0) GO TO 400
      IF(ANS.EQ.0) GO TO 150
      ANS = 1
      CALL RADION('Select output format',PROMPT,2,ANS,
     +IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
      IF (ANS.LT.1) GO TO 400
      IF(ANS.EQ.1) THEN
        CALL FMTDK(IDEV,SEQ1,IDIM)
      ELSE
        CALL WRITCF(IDEV,SEQ1,IDIM,NAMPRO,KBOUT,IOK)
      END IF
      RETURN
 400  CONTINUE
      CLOSE(UNIT=IDEV)
      END
C   SUBROUTINE TO ENTER NEW GEL SEQUENCES INTO DATA BASE.
C   IT READS IN AN ARCHIVE VERSION AND WRITES OUT A WORKING VERSION.
C   IT ALSO SETS UP ANY RELATIONSHIPS WITH OTHER DATA IN THE DATABASE
C   BOTH BY POSITION IN A CONTIG AND POINTERS TO LEFT AND RIGHT
C   NEIGHBOURS.
      SUBROUTINE AENTER(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +GEL,NAMARC,X,ITYPE,ISENSE,SEQC2,ITOTPC,
     +IDIM,IDC,NCONTC,LINCON,IFAIL,IDBSIZ,KBOUT,IDEVR,IDEVW,IDEVN,
     +IDEVT,IDEVC,IDEVG,MAXGEL)
C   AUTHOR: RODGER STADEN
      INTEGER  RELPG(IDBSIZ),X,Y
      INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
      CHARACTER GEL(MAXGEL),NAMARC*(*)
      CHARACTER SEQC2(IDC)
      CHARACTER NAMARK*16
C      WRITE(*,*)'X,ITYPE,ISENSE,IDIM,IDC'
C      WRITE(*,*)X,ITYPE,ISENSE,IDIM,IDC
C   SET FAIL FLAG
      IFAIL=0
C      WRITE(KBOUT,1000)
C1000  FORMAT(' TRYING TO ENTER NEW GEL READING INTO DATABASE')
C   IS THERE SPACE?
      IF((IDBSIZ-(NGELS+NCONTS)).GT.2)GO TO 5
C   FULL
      WRITE(KBOUT,1999)IDBSIZ
1999  FORMAT(' Database full, current size=',I6,' Extend with copy')
      IFAIL=7
      RETURN
5     CONTINUE
C   NEED TO CHECK TO SEE IF GEL ALREADY IN DB
C   LOOK THRU ARC FILE
      DO 10 J=1,NGELS
      CALL READN(IDEVN,J,NAMARK)
      IF(NAMARK.NE.NAMARC(1:16))GO TO 10
C   FOUND
      WRITE(KBOUT,1013)J
1013  FORMAT(' New gel already in database with number',I6,
     +' Entry aborted')
      IFAIL=6
      RETURN
10    CONTINUE
C   INCREMENT NUMBER OF GELS
      NGELS=NGELS+1
C   SET LENGTH THIS GEL
      LNGTHG(NGELS)=IDIM*ISENSE
C   WRITE NAME OF ARCHIVE TO LIST OF ARCHIVES
C   NAMPRO,ARC
      NAMARK=NAMARC(1:16)
      CALL WRITEN(IDEVN,NGELS,NAMARK)
      WRITE(KBOUT,1003)NGELS
1003  FORMAT(' This gel reading has been given the number ',I6)
C   WRITE GEL TO WORKING VERSION
      CALL WRITEW(IDEVW,NGELS,GEL,MAXGEL)
      IF(IDEVT.GT.0) CALL ENTRD(IDEVG,IDEVT,IDEVC,NAMARC,NGELS,IOK)
C   CREATE TAGS FOR THIS NASTY
      CALL TAGGEL(NGELS,LNGTHG(NGELS),GEL)
C   SET UP RELATIONSHIPS
C   DOES THIS GEL OVERLAP?
      IF(ITYPE.NE.0)GO TO 100
C
C   DOES NOT OVERLAP SO IT STARTS A CONTIG OF ITS OWN
C   SET LEFT AND RIGHT POINTERS TO ZERO,RELPG TO 1
      LNBR(NGELS)=0
      RNBR(NGELS)=0
      RELPG(NGELS)=1
C   WRITE NEW GEL LINE
      CALL WRITER(IDEVR,NGELS,RELPG(NGELS),LNGTHG(NGELS),
     +LNBR(NGELS),RNBR(NGELS))
C
C   SET CONTIG POINTERS AND GENERAL VALUES
C   INCREMENT NUMBER OF CONTIGS
      NCONTS=NCONTS+1
C   POINTER TO THIS CONTIG
      N=IDBSIZ-NCONTS
C   POINTER TO LEFT GEL THIS CONTIG
      LNBR(N)=NGELS
C   POINTER TO RIGHT GEL THIS CONTIG
      RNBR(N)=NGELS
C   LENGTH OF CONTIG
      RELPG(N)=IDIM
C   WRITE CONTIG DESCRIPTOR
      CALL WRITER(IDEVR,N,RELPG(N),LNGTHG(N),
     +LNBR(N),RNBR(N))
C   WRITE DB DESCRIPTOR
      CALL WRITER(IDEVR,IDBSIZ,NGELS,NCONTS,NGELS,NCONTS)
      RETURN
C
100   CONTINUE
C
C
C   DOES OVERLAP
150   CONTINUE
C
C   LEFT END OR RIGHT OVERLAP?
      IF(ITYPE.EQ.1)GO TO 400
C   RIGHT END OR INTERNAL OVERLAP
C
160   CONTINUE
C   NEED TO SEARCH THRU THIS CONTIG TO FIND LEFT AND RIGHT
C   NEIGHBOURS FOR THIS NEW GEL
C   LINE NUMBER OF LEFT END OF CONTIG
      N=NCONTC
C   LOOK THRU UNTIL CURRENT IS >= THEN IT MUST BE THE PREVIOUS ONE
200   CONTINUE
      IF(RELPG(N).GT.X)GO TO 250
C   IS THIS THE LAST GEL IN CONTIG?
      IF(RNBR(N).EQ.0)GO TO 350
C   NO SO LOOK AT NEXT
      N=RNBR(N)
      GO TO 200
250   CONTINUE
C   GEL LIES BETWEEN N AND LNBR(N)
C   NEED TO EDIT DB HERE
      IF(ITOTPC.GT.0)CALL ABEDIN(RELPG,LNGTHG,LNBR,RNBR,
     1NGELS,NCONTS,
     2GEL,LINCON,X,SEQC2,ITOTPC,IDC,IDBSIZ,KBOUT,IDEVR,IDEVW,
     +MAXGEL)
C
C
C   SET POINTERS IN NEW GEL
      LNBR(NGELS)=LNBR(N)
      RNBR(NGELS)=N
      RELPG(NGELS)=X
C   WRITE NEW GEL LINE
      CALL WRITER(IDEVR,NGELS,RELPG(NGELS),LNGTHG(NGELS),
     +LNBR(NGELS),RNBR(NGELS))
C   SET POINTERS  IN LEFT AND RIGHT NEIGHBOURS
      K=LNBR(N)
      RNBR(K)=NGELS
C      RNBR(LNBR(N))=NGELS
C   WRITE LEFT AND RIGHT NEIGHBOURS
      CALL WRITER(IDEVR,K,RELPG(K),LNGTHG(K),
     +LNBR(K),RNBR(K))
      LNBR(N)=NGELS
      CALL WRITER(IDEVR,N,RELPG(N),LNGTHG(N),
     +LNBR(N),RNBR(N))
C   WRITE NGELS NCONTS
      CALL WRITER(IDEVR,IDBSIZ,NGELS,NCONTS,NGELS,NCONTS)
C   HAVE WE INCREASED LENGTH OF CONTIG?
C   ITS LINE NUMBER IS LINCON
C   NEED TO UPDATE IDIM IN CASE OF EDITS
      IDIM=ABS(LNGTHG(NGELS))
      Y=X+IDIM-1
      IF(Y.LE.RELPG(LINCON))RETURN
      RELPG(LINCON)=Y
C   WRITE NEW CONTIG LINE
      CALL WRITER(IDEVR,LINCON,RELPG(LINCON),LNGTHG(LINCON),
     +LNBR(LINCON),RNBR(LINCON))
      RETURN
350   CONTINUE
C   MUST BE A RIGHT END OVERLAP
C   NEED TO EDIT DB HERE
      IF(ITOTPC.GT.0)CALL ABEDIN(RELPG,LNGTHG,LNBR,RNBR,
     1NGELS,NCONTS,
     2GEL,LINCON,X,SEQC2,ITOTPC,IDC,IDBSIZ,KBOUT,IDEVR,IDEVW,
     +MAXGEL)
C
C
C   SET POINTERS FOR NEW GEL
      LNBR(NGELS)=N
      RNBR(NGELS)=0
      RELPG(NGELS)=X
C   WRITE NEW GEL LINE
      CALL WRITER(IDEVR,NGELS,RELPG(NGELS),LNGTHG(NGELS),
     +LNBR(NGELS),RNBR(NGELS))
C   OLD RIGHT END
      RNBR(N)=NGELS
C   WRITE NEW RIGHT LINE
      CALL WRITER(IDEVR,N,RELPG(N),LNGTHG(N),
     +LNBR(N),RNBR(N))
C   RESET RIGHT NAME IN CONTIG
C   ITS LINE NUMBER IS LINCON
      RNBR(LINCON)=NGELS
C   HAVE WE INCREASED LENGTH OF CONTIG?
C   NEED TO UPDATE LENGTH OF GEL IN CASE OF EDITS
      IDIM=ABS(LNGTHG(NGELS))
      Y=X+IDIM-1
      RELPG(LINCON)=MAX(RELPG(LINCON),Y)
C   WRITE HERE
C   WRITE CONTIG DESCRIPTOR
      CALL WRITER(IDEVR,LINCON,RELPG(LINCON),LNGTHG(LINCON),
     +LNBR(LINCON),RNBR(LINCON))
      CALL WRITER(IDEVR,IDBSIZ,NGELS,NCONTS,NGELS,NCONTS)
      RETURN
C
400   CONTINUE
C
C   ADDING TO LEFT END
410   CONTINUE
C   NEED TO EDIT DB HERE
      IF(ITOTPC.GT.0)CALL ABEDIN(RELPG,LNGTHG,LNBR,RNBR,
     1NGELS,NCONTS,
     2GEL,LINCON,1,SEQC2,ITOTPC,IDC,IDBSIZ,KBOUT,IDEVR,IDEVW,
     +MAXGEL)
C
420   CONTINUE
C   SET POINTERS IN NEW GEL
      RELPG(NGELS)=1
      RNBR(NGELS)=NCONTC
      LNBR(NGELS)=0
C   WRITE NEW GEL LINE
      CALL WRITER(IDEVR,NGELS,RELPG(NGELS),LNGTHG(NGELS),
     +LNBR(NGELS),RNBR(NGELS))
C   SET POINTERS IN OLD LEFT END
      LNBR(NCONTC)=NGELS
      RELPG(NCONTC)=X
C   WRITE NEW LEFT END
      CALL WRITER(IDEVR,NCONTC,RELPG(NCONTC),LNGTHG(NCONTC),
     +LNBR(NCONTC),RNBR(NCONTC))
C   NEW LENGTH OF CONTIG
      RELPG(LINCON)=RELPG(LINCON)+X-1
C   MAY HAVE JUST ADDED A GEL LONGER THAN CONTIG
      IDIM=ABS(LNGTHG(NGELS))
      Y=IDIM
      IF(Y.GT.RELPG(LINCON))RELPG(LINCON)=Y
C   NEW NAME OF LEFT END OF CONTIG
      LNBR(LINCON)=NGELS
C   WRITE CONTIG DESCRIPTOR
      CALL WRITER(IDEVR,LINCON,RELPG(LINCON),LNGTHG(LINCON),
     +LNBR(LINCON),RNBR(LINCON))
      CALL WRITER(IDEVR,IDBSIZ,NGELS,NCONTS,NGELS,NCONTS)
C   NOW GO THRU AND CHANGE ALL RELATIVE POSITIONS
      N=NCONTC
440   CONTINUE
      IF(RNBR(N).EQ.0)RETURN
      N=RNBR(N)
      RELPG(N)=RELPG(N)+X-1
C   WRITE NEW LINE
      CALL WRITER(IDEVR,N,RELPG(N),LNGTHG(N),
     +LNBR(N),RNBR(N))
      GO TO 440
      END
      SUBROUTINE COPYTG(IDEVT,IDEV,IOK,IDBSIZ,NEWSIZ,NGELS)
C Read tag details
      IDIFF = NEWSIZ - IDBSIZ
      CALL READTG(IDEVT,IDBSIZ,ICNT,LLEN,LCOM,LTYPE,NEXT)
      IF (NEXT.NE.0) NEXT = NEXT + IDIFF
      CALL WRITTG(IDEV,NEWSIZ,ICNT+IDIFF,LLEN,LCOM,LTYPE,NEXT)
C Copy headers for each gels
      DO 10 I = 1,NGELS
        CALL READTG(IDEVT,I,LPOS,LLEN,LCOM,LTYPE,NEXT)
        IF (NEXT.NE.0) NEXT = NEXT + IDIFF
        CALL WRITTG(IDEV,I,LPOS,LLEN,LCOM,LTYPE,NEXT)
 10   CONTINUE
C Copy rest of tags
      DO 20 I = IDBSIZ+1, ICNT
        CALL READTG(IDEVT,I,LPOS,LLEN,LCOM,LTYPE,NEXT)
        IF (NEXT.NE.0) NEXT = NEXT + IDIFF
        CALL WRITTG(IDEV,I+IDIFF,LPOS,LLEN,LCOM,LTYPE,NEXT)
 20   CONTINUE
      IOK = 0
      END
      SUBROUTINE COPYCC(IDEVC,IDEV,IOK)
C  COMMENT_LENGTH
      CHARACTER NOTE*40
      CALL READCC(IDEVC,1,ICNT,NEXT,NOTE)
      CALL WRITCC(IDEV,1,ICNT,NEXT,NOTE)
      DO 10 I = 2,ICNT
        CALL READCC(IDEVC,I,ICNT,NEXT,NOTE)
        CALL WRITCC(IDEV,I,ICNT,NEXT,NOTE)
 10   CONTINUE
      IOK = 0
      END
      SUBROUTINE DBAUTO(RELPG,LNGTHG,LNBR,RNBR,MAXDB,IDBSIZ,
     +NGELS,NCONTS,MAXGEL,
     +TEMP3,WORDP,WORDN,LPOWRC,POSNS,GELN,
     +SEQ1,MAXSEQ,SEQ2,SEQ3,SEQ4,SEQ5,SEQC2,SEQG2,MATCH,
     +MAXGLM,MAXGL2,CHRSIZ,ECHRSZ,LENGTH,
     +SAV1,SAV2,SAV3,MAXSAV,CENDS,NENDS,MAXCON,CONST,
     +KBIN,KBOUT,IDEV1,IDEV2,IDEV3,IDEV4,IDEV7,IDEV8,IDEV,IDEVT,IDEVC,
     +IHELPS,IHELPE,HELPF,IDEVH,NAMARC,NAMPRO,FILE,
     +PERCD,IOPEN,IDM,SEQG3,SEQC3,IOK)
      INTEGER CHRSIZ,ECHRSZ
      INTEGER RELPG(MAXDB),PL(2),PR(2),RMOST
      INTEGER LNGTHG(MAXDB),LNBR(MAXDB),RNBR(MAXDB)
      INTEGER JOINT(2),ITOTPC(2),ITOTPG(2),IDIM22(2),IDOUT(2)
      INTEGER LINCON(2),LLINO(2),ITYPE(2),IFAIL(2)
      INTEGER ILEFTS(2),ILC(2),IPOSC(2),IPOSG(2),ISENSE(2)
      INTEGER LREG,RREG,X,ANSJOK
      INTEGER TEMP3(ECHRSZ,MAXGL2),CONST(LENGTH)
      INTEGER POSNS(MAXSEQ),WORDP(LPOWRC),WORDN(LPOWRC),GELN(MAXGLM)
      INTEGER CENDS(MAXCON),NENDS(MAXCON)
      CHARACTER SEQ3(MAXGLM),SEQC2(MAXGLM,2),SEQG2(MAXGLM,2)
      CHARACTER SEQ1(MAXSEQ),SEQ2(MAXGLM),MATCH(MAXGLM),SEQ4(MAXGLM)
      INTEGER SAV1(MAXSAV),SAV2(MAXSAV),SAV3(MAXSAV),CSTART
      CHARACTER NAMARC*(*),NAMPRO*(*),FILE*(*)
      CHARACTER GET,SEQ5(MAXGLM),HELPF*(*),SEQG3(MAXGLM),SEQC3(MAXGLM)
      PARAMETER (MAXPRM = 32)
      CHARACTER PROMPT(3)*(MAXPRM)
      REAL PERMIS(2)
      INTEGER GNFFOF
      EXTERNAL GNFFOF
      SAVE GET
      DATA GET/'>'/
      WRITE(KBOUT,*)' Automatic sequence assembler'
C
C set flag for saving alignment scores
C
      IREPSC = 1
      ICRAP = 1
      IFAIL(1) = 0
      IEMPTY=0
      IF(NGELS.LT.1)IEMPTY=1
      CALL DBCHEK(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +TEMP3,IERR,KBOUT)
      IF(IERR.GT.1) RETURN
      CALL YESNO(IOKENT,'Permit entry',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IOKENT.LT.0) RETURN
      CALL YESNO(ISHOW,'Hide alignments',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(ISHOW.LT.0) RETURN
      CALL YESNO(INF,'Use file of file names',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(INF.LT.0) RETURN
      IF(INF.EQ.0) THEN
        FILE = ' '
        CALL OPENF1(IDEV7,FILE,0,IOK,KBIN,KBOUT,
     +  'File of gel reading names',
     +  IHELPS,IHELPE,HELPF,IDEVH)
        IF(IOK.NE.0) RETURN
      END IF
      IF(IOKENT.EQ.0) THEN
        FILE = ' '
        CALL OPENF1(IDEV8,FILE,1,IOK,KBIN,KBOUT,
     +  'File for names of failures',
     +  IHELPS,IHELPE,HELPF,IDEVH)
        IF(IOK.NE.0) RETURN
      ELSE
        CALL YESNO(IREPSC,'Save alignment scores in a file',
     +  IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        IF(IREPSC.LT.0) RETURN
        IF(IREPSC.EQ.0) THEN
          FILE = ' '
          CALL OPENF1(IDEV8,FILE,1,IOK,KBIN,KBOUT,
     +    'File for names and scores',
     +    IHELPS,IHELPE,HELPF,IDEVH)
          IF(IOK.NE.0) RETURN
          CALL YESNO(ICRAP,'Use poor data',
     +    IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
          IF(ICRAP.LT.0) RETURN
        END IF
      END IF
      PROMPT(1) = 'Perform normal shotgun assembly'
      PROMPT(2) = 'Put all sequences in one contig'
      PROMPT(3) = 'Put all sequences in new contigs'
      IOPT = 1
      CALL RADION('Select entry mode',PROMPT,3,IOPT,
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IOPT.LT.1) RETURN
      IF(IOPT.EQ.1) THEN
C  parameters for normal assembly
        ANSJOK = 0
        CALL YESNO(ANSJOK,'Permit joins',
     +  IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        IF(ANSJOK.LT.0) RETURN
        MN = LENGTH*2
        MX = MAXGLM + 1
        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
        MINSLI = 3
        MN = 0
        MX = 25
        MAXPG = 8
        CALL GETINT(MN,MX,MAXPG,
     +  'Maximum pads per gel',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        MAXPG = IVAL
        MN = 0
        MX = 25
        MAXPC = 8
        CALL GETINT(MN,MX,MAXPC,
     +  'Maximum pads per gel in contig',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        MAXPC = IVAL
C        IF((IOKENT.EQ.0).OR.(IREPSC.EQ.0)) THEN
          RMN = 0.
          RMX = 100.
          PERMAX = 8.
          CALL GETRL(RMN,RMX,PERMAX,
     +    'Maximum percent mismatch after alignment',
     +    VAL,KBIN,KBOUT,
     +    IHELPS,IHELPE,HELPF,IDEVH,IOK)
          IF(IOK.NE.0) RETURN
          PERMAX = VAL
C        END IF
        IDIM1=0
        MAXOVR=MAXGEL-3*MAX(MAXPC,MAXPG)
        JGEL = 0
        JNGEL = 0
        JNJOIN = 0
        JOINF = 0
        IMATC = 0
        IF(IEMPTY.EQ.0) THEN
          JOB = 0
          CALL ACONSN(RELPG,LNGTHG,LNBR,RNBR,NAMPRO,NGELS,NCONTS,
     +    SEQ1,MAXSEQ,SEQ2,IDBSIZ,IDIM1,JOB,KDUMM,KDUMM,KDUMM,TEMP3,
     +    ECHRSZ,MAXGL2,KBOUT,IDEV2,IFAIL(1),MAXGEL,IDM,PERCD)
          IF(IFAIL(1).NE.0) THEN
            CALL ERROM(KBOUT,'Error calculating consensus')
            GO TO 900
          END IF
        END IF
C
C init hashing constants
C
        CALL INITE(CONST,CSTART,LENGTH)
      END IF
C
C set intitial values for contig count and number of readings
C just to get thru the first consensus calc
      NGELSL = NGELS + 2
      NCONTL = NCONTS +1
C
C
C                          MAIN LOOP
C
C
1     CONTINUE
C      IF(IDIM1.GT.0)CALL FMTDB(SEQ1,IDIM1,1,IDIM1,60,IDEV)
C
C
      IDIM2=MAXGEL
      IF(INF.EQ.1) THEN
3       CONTINUE
        MN = 0
        CALL GTSTR('Gel reading name',' ',NAMARC,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
        IOK = GNFFOF(IDEV7,NAMARC)
        IF(IOK.EQ.1) GO TO 900
        IF(IOK.NE.0) GO TO 1
      END IF
      DO 77 MM=1,80
        MATCH(MM)=GET
77    CONTINUE
      WRITE(IDEV,1077)(MATCH(KK),KK=1,79)
1077  FORMAT(' ',79A1)
      JGEL = JGEL + 1
      WRITE(IDEV,*)'Processing',JGEL,' in batch'
1007  FORMAT(' Gel reading name=',A)
      WRITE(IDEV,1007)NAMARC
      CALL OPENRS(IDEV4,NAMARC,IOK,LRECL,2)
      IF(IOK.NE.0)THEN
C        IF(INF.EQ.1) RETURN
        CALL AERROR(IDEV,IDEV8,NAMARC,0)
        GO TO 1
      END IF
      CALL ARRFIN(IDEV4,SEQ2,IDIM2,KBOUT,ICRAP)
      CLOSE(UNIT=IDEV4)
      WRITE(IDEV,1800)IDIM2
1800  FORMAT(' Gel reading length=',I6)
C
C
C
      IF(IOPT.NE.1) THEN
        CALL DBAUTP(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +  SEQ2,NAMARC,JOINT,ITYPE,ISENSE,SEQC2,ITOTPC,
     +  IDIM2,IDOUT,LLINO,LINCON,IFAIL,IDBSIZ,MAXDB,IDEV,
     +  IDEV1,IDEV2,IDEV3,IDEVT,IDEVC,IDEV4,MAXGEL,IMATC,IEMPTY,IOPT)
        IF(IFAIL(1).NE.0) THEN
          CALL AERROR(IDEV,IDEV8,NAMARC,0)
        ELSE
          JNGEL = JNGEL + 1
        END IF  
        GO TO 1
      END IF
      IF(IDIM2.LT.MINMAT)THEN
        CALL AERROR(IDEV,IDEV8,NAMARC,1)
        GO TO 1
      END IF
      CALL SQCOPY(SEQ2,SEQ3,IDIM2)
      IFCOMP=0
      IMATC=0
      JOBC = 2
      IF ((NGELSL.LT.NGELS).AND.(NCONTL.LT.NCONTS)) THEN
        JOBC = 1
      ELSE IF (NGELSL.EQ.NGELS) THEN
        JOBC = 0
      END IF
      NGELSL = NGELS
      NCONTL = NCONTS
      IF(IEMPTY.EQ.0)
     +CALL AUTOCN(SEQ1,IDIM1,SEQ2,IDIM2,ILEFTS,ILC,IPOSC,
     +IPOSG,ISENSE,LLINO,IMATC,IFCOMP,MINMAT,POSNS,WORDP,WORDN,
     +CONST,LENGTH,LPOWRC,IDEV,MATCH,MAXGEL,MAXGLM,SEQ5,GELN,
     +SAV1,SAV2,SAV3,MAXSAV,CENDS,NENDS,MAXCON,
     +SEQG2,SEQC2,SEQ4,IDOUT,IDIM22,ITOTPG,ITOTPC,JOINT,IFAIL,
     +ITYPE,MAXPC,MAXPG,PERMAX,MINSLI,SEQG3,SEQC3,KFAIL,CSTART,
     +JOBC,PERMIS,LENO,ISHOW)
      IF(IREPSC.EQ.0) THEN
        IF(IFCOMP.NE.0) THEN
          CALL AERROR(IDEV,IDEV8,NAMARC,2)
          GO TO 1
        END IF
        IF(IMATC.GT.0) THEN
          WRITE(IDEV8,1022)NAMARC,PERMIS(1),IDIM2,LENO
        ELSE
          PERMIS(1) = 0.
          LENO = 0
          WRITE(IDEV8,1022)NAMARC,PERMIS(1),IDIM2,LENO
        END IF
      END IF
 1022 FORMAT(' ',A,F5.1,2I6)
      IF(IOKENT.NE.0) GO TO 1
C     THIS RETURNS THE FOLLOWING:
C     ILEFTS  POSITION IN CONSENSUS OF LEFT END OF MATCHING CONTIGS
C     ILC     LENGTHS OF MATCHING CONTIGS
C     IPOSC   POSITION OF MATCH RELATIVE TO CONTIG
C     IPOSG   POSITION OF MATCH RELATIVE TO NEW GEL
C     ISENSE  SENSE OF NEW GEL
C     LLINO   LEFT GEL NUMBER IN MATCHING CONTIGS
C     IMATC   THE NUMBER OF MATCHING CONTIGS (>2 IS ERROR!)
C     IFCOMP  ERROR FLAG FOR COMPARISON (COMPARISON ARRAYS OVERFLOWED)
      IF(IFCOMP.NE.0) THEN
        CALL AERROR(IDEV,IDEV8,NAMARC,2)
        GO TO 1
      END IF
      CALL SQCOPY(SEQ3,SEQ2,IDIM2)
      IF(IMATC.EQ.0) THEN
C
C                     NO OVERLAP NEW CONTIG
C
C     ITYPE 0 = NO OVERLAP
C     ISENSE 1 = SAME SENSE AS ARCHIVE
        IF(IFAIL(1).NE.0) THEN
          CALL AERROR(IDEV,IDEV8,NAMARC,2)
          GO TO 1
        END IF
        ITYPE(1)=0
        ISENSE(1)=1
        IDOUT(1)=MAXGEL
        WRITE(IDEV,1015)
1015    FORMAT(' New gel reading does not overlap: start a new contig')
        CALL AENTER(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +  SEQ2,NAMARC,X,ITYPE,ISENSE,SEQC2(1,1),ITOTPC(1),
     +  IDIM2,IDOUT(1),LLINO,LINCON,IFAIL,IDBSIZ,IDEV,
     +  IDEV1,IDEV2,IDEV3,IDEVT,IDEVC,IDEV4,MAXGEL)
        IF(IFAIL(1).NE.0) THEN
          CALL AERROR(IDEV,IDEV8,NAMARC,3)
          GO TO 1
        END IF
        IEMPTY=0
        IDIM1=IDIM1+1
        IF((IDIM1+19+IDIM2).GT.MAXSEQ)THEN
          WRITE(IDEV,1021)MAXSEQ
1021      FORMAT(' Database maximum consensus length (',I6,') exceeded')
          GO TO 900
        END IF
        CALL ADDTIT(SEQ1(IDIM1),NAMPRO,NGELS,IDIM1)
        CALL MSTLKL(SEQ2,IDIM2)
        CALL SQCOPY(SEQ2,SEQ1(IDIM1),IDIM2)
        IDIM1=IDIM1+IDIM2-1
        JNGEL = JNGEL + 1
        GO TO 1
      END IF
C
C
C                     OVERLAP SO TRY TO ALIGN THE SEQUENCES
C
C
      DO 100 I=1,IMATC
        N=IDBSIZ-NCONTS
        DO 99 J=N,IDBSIZ-1
          IF(LNBR(J).NE.LLINO(I))GO TO 99
          LINCON(I)=J
          GO TO 100
99      CONTINUE
        WRITE(IDEV,10077)LLINO(I)
10077   FORMAT(' Contig line for contig',I6,' not found!')
        GO TO 900
100   CONTINUE
C
      IF (IMATC.EQ.1) THEN
C
C
C                     SINGLE OVERLAP
C
C
C
        WRITE(IDEV,1014)LLINO(1)
1014    FORMAT(' New gel reading overlaps contig',I6)
        IF(ITOTPG(1).GT.0) CALL CCTA(SEQG2(1,1),IDIM22(1))
        CALL AENTER(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +  SEQG2(1,1),NAMARC,JOINT(1),ITYPE(1),ISENSE(1),
     +  SEQC2(1,1),
     +  ITOTPC(1),IDIM22(1),IDOUT(1),LLINO(1),LINCON(1),
     +  IFAIL(1),IDBSIZ,IDEV,IDEV1,IDEV2,IDEV3,IDEVT,IDEVC,IDEV4,MAXGEL)
        IF(IFAIL(1).NE.0) THEN
          CALL AERROR(IDEV,IDEV8,NAMARC,3)
          GO TO 1
        END IF
        JNGEL = JNGEL + 1
        CALL UPDCON(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,NGELS,NCONTS,
     +  SEQ1,MAXSEQ,IDIM1,ILEFTS(1),ILC(1),LINCON(1),NAMPRO,SEQ2,TEMP3,
     +  ECHRSZ,MAXGL2,KBOUT,IDEV,IDEV2,IFAIL(1),MAXGEL,IDM,PERCD)
        IF(IFAIL(1).NE.0) THEN
          CALL ERROM(KBOUT,'Error calculating consensus')
          GO TO 900
        END IF
        IF(KFAIL.NE.0) THEN
C          CALL AERROR(IDEV,IDEV8,NAMARC,4)
        END IF
        GO TO 1
      END IF
C
C
C                     DOUBLE OVERLAP
C
C
      WRITE(IDEV,1013)LLINO
1013  FORMAT(' Overlap between contigs',I6,' and',I6)
      IF(ANSJOK.NE.0) GO TO 1
      IF(LLINO(1).EQ.LLINO(2))THEN
        WRITE(IDEV,*)' Trying to form loop in contig',LLINO(1)
        WRITE(IDEV,*)' Gel not entered'
        CALL AERROR(IDEV,IDEV8,NAMARC,3)
        GO TO 1
      END IF
      CALL AJOIN3(RELPG,IDBSIZ,LINCON,ITYPE,ISENSE,JOINT,
     +IDIM22,KLASS,IOVER,IDEV,PL,PR)
      IF(IOVER.GT.MAXOVR)THEN
        WRITE(IDEV,*)' Overlap too large: entry only'
C
C cannot align the two contigs, so try to enter the reading into one of them
C
        IFAIL(2)=1
        IGOOD=0
        IF(IFAIL(1).EQ.0)IGOOD=1
        IF(IFAIL(2).EQ.0)IGOOD=2
        IF(IGOOD.EQ.0) THEN
          CALL AERROR(IDEV,IDEV8,NAMARC,2)
          JOINF = JOINF + 1
          GO TO 1
        END IF
        IF(ITOTPG(IGOOD).GT.0) CALL CCTA(SEQG2(1,IGOOD),IDIM22(IGOOD))
        WRITE(IDEV,1012)LLINO(IGOOD)
        CALL AENTER(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +  SEQG2(1,IGOOD),NAMARC,JOINT(IGOOD),ITYPE(IGOOD),
     +  ISENSE(IGOOD),SEQC2(1,IGOOD),ITOTPC(IGOOD),
     +  IDIM22(IGOOD),IDOUT(IGOOD),LLINO(IGOOD),LINCON(IGOOD),
     +  IFAIL(IGOOD),IDBSIZ,IDEV,IDEV1,IDEV2,IDEV3,IDEVT,IDEVC,IDEV4,
     +  MAXGEL)
        IF(IFAIL(IGOOD).NE.0) THEN
          CALL AERROR(IDEV,IDEV8,NAMARC,3)
          JOINF = JOINF + 1
          GO TO 1
        END IF
        JNGEL = JNGEL + 1
        CALL UPDCON(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,NGELS,NCONTS,
     +  SEQ1,MAXSEQ,IDIM1,ILEFTS(IGOOD),ILC(IGOOD),LINCON(IGOOD),
     +  NAMPRO,SEQ2,TEMP3,
     +  ECHRSZ,MAXGL2,KBOUT,IDEV,IDEV2,IFAIL(1),MAXGEL,IDM,PERCD)
        IF(IFAIL(1).NE.0) THEN
          CALL ERROM(KBOUT,'Error calculating consensus')
          GO TO 900
        END IF
        WRITE(IDEV,1020)LLINO,LLINO(IGOOD)
 1020   FORMAT(' Could not join contigs',I4,' and',I4,' but the gel',
     +  ' has been entered into contig',I4,/,
     +  ' If required do the join manually.')
        JOINF = JOINF + 1
        GO TO 1
      END IF
C   WHICH CONTIG IS LEFTMOST?
      LMOST=1
      RMOST=2
      IF(PL(1).GT.PL(2))THEN
        LMOST=2
        RMOST=1
      END IF
C   SAVE LENGTH OF RMOST CONTIG FOR DELETION STEP LATER
      ILCR=ILC(RMOST)
      IF(ITOTPG(LMOST).GT.0) CALL CCTA(SEQG2(1,LMOST),IDIM22(LMOST))
      WRITE(IDEV,1012)LLINO(LMOST)
1012  FORMAT(' Entering the new gel reading into contig',I6)
      CALL AENTER(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +SEQG2(1,LMOST),NAMARC,JOINT(LMOST),ITYPE(LMOST),
     +ISENSE(LMOST),SEQC2(1,LMOST),ITOTPC(LMOST),
     +IDIM22(LMOST),IDOUT(LMOST),LLINO(LMOST),LINCON(LMOST),
     +IFAIL(LMOST),IDBSIZ,IDEV,IDEV1,IDEV2,IDEV3,IDEVT,IDEVC,IDEV4,
     +MAXGEL)
      IF(IFAIL(LMOST).NE.0) THEN
        CALL AERROR(IDEV,IDEV8,NAMARC,3)
        JOINF = JOINF + 1
        GO TO 1
      END IF
      JNGEL = JNGEL + 1
      CALL UPDCON(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,NGELS,NCONTS,
     +  SEQ1,MAXSEQ,IDIM1,ILEFTS(LMOST),ILC(LMOST),LINCON(LMOST),
     +  NAMPRO,SEQ2,TEMP3,
     +  ECHRSZ,MAXGL2,KBOUT,IDEV,IDEV2,IFAIL(1),MAXGEL,IDM,PERCD)
      IF(IFAIL(1).NE.0) THEN
        CALL ERROM(KBOUT,'Error calculating consensus')
        GO TO 900
      END IF
      IF(ITYPE(LMOST).EQ.1)LLINO(LMOST)=NGELS
      IF(ILEFTS(LMOST).LT.ILEFTS(RMOST))THEN
        ILEFTS(RMOST)=ILEFTS(RMOST) + 
     +  (RELPG(LINCON(LMOST)) - ILC(LMOST))
      END IF
      ILC(LMOST) =  RELPG(LINCON(LMOST))
      DO 500 I=1,2
        IF(ISENSE(I).EQ.-1)THEN
          CALL CMPLMT(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,LINCON(I),
     +    LLINO(I),SEQ2,IDBSIZ,IDEV,IDEV1,IDEV2,MAXGEL)
          CALL SQREV(SEQ1(ILEFTS(I)),ILC(I))
          CALL SQCOM(SEQ1(ILEFTS(I)),ILC(I))
          KT=IDIM1
          CALL ADDTIT(SEQ1((ILEFTS(I)-20)),NAMPRO,LNBR(LINCON(I)),KT)
        END IF
500   CONTINUE
C   NEED TO KNOW POSITION OF OVERLAP RELATIVE TO CONTIG, TO CONSENSUS
C   WHICH BITS TO SEND TO ALIGNMENT ROUTINES
C   SET UP FOR ALINE (NOTE RMOST IS EQUIVALENT TO THE GEL READING AND
C   SO IS SLID ALONG THE LMOST CONTIG. THE SECTION SENT TO ALINE MUST 
C   BE OF LENGTH < MAXGEL-2*MAX(MAXPC,MAXPG)
C   IT MUST START AT POSITION 1 IN THE RMOST CONTIG AND EXTEND
      IPOSC(LMOST)=PL(RMOST)+RELPG(NGELS)-1
      ILCT = RELPG(LINCON(LMOST)) - RELPG(NGELS) - PL(RMOST) + 2
      ILC(RMOST)=MIN(ILCT,ILC(RMOST))
      IPOSC(RMOST)=1
      IDOUT(LMOST)=MAXGEL
      IDOUT(RMOST)=MAXGEL
      IDSAV=MAXSAV
C  ON INPUT TO ALINE ILC(RMOST) CONTAINS THE OVERLAP LENGTH
C  ON OUTPUT IT CONTAINS THE LENGTH OF THE ALIGNED SECTION (IE INCLUDING 
C  PADS)
      WRITE(IDEV,1009)
1009  FORMAT(' Trying to align the two contigs')
      CALL ALINE(SEQ1(ILEFTS(LMOST)),SEQ1(ILEFTS(RMOST)),
     +SEQC2(1,RMOST),SEQC2(1,LMOST),SAV1,SAV2,SAV3,IDSAV,
     +ILC(LMOST),ILC(RMOST),IDOUT(LMOST),IPOSC(LMOST),IPOSC(RMOST),
     +MINSLI,JOINT(LMOST),ITOTPC(LMOST),ITOTPC(RMOST),IFAIL(1),
     +ITYPE(1),MAXPC,MAXPC,PERMAX,IDEV,SEQ4,MAXGEL,Z,LENO,ISHOW)
C SEQC2(1,LMOST)  NOW CONTAINS THE ALIGNED SECTION OF THE LMOST CONTIG
C SEQC2(1,RMOST)  NOW CONTAINS THE ALIGNED SECTION OF THE RMOST CONTIG
C ILC(RMOST)  IS NOW THE LENGTH OF ALIGNED SECTION OF THE RMOST CONTIG
C IDOUT(LMOST)  IS NOW THE LENGTH OF ALIGNED SECTION OF THE LMOST CONTIG
C JOINT(LMOST)  IS THE POSITION OF THE JOIN RLETIVE TO THE LMOST CONTIG
C ITYPE IS TYPE OF OVERLAP (-1 = RIGHT END OR INTERNAL, 1 = LEFT END)
C  NB SHOULD ALWAYS BE -1
C  IF THIS HAS BEEN DONE OK WE CAN EDIT THE TWO CONTIGS THEN JOIN
      IF(IFAIL(1).NE.0)THEN
        WRITE(IDEV,*)' Failed to align the two overlapping contigs'
C        CALL AERROR(IDEV,IDEV8,NAMARC,4)
        JOINF = JOINF + 1
        GO TO 1
      END IF
      IF(ITOTPC(LMOST).GT.0)THEN
        WRITE(IDEV,1017)LLINO(LMOST)
1017    FORMAT(' Editing contig',I6)
        CALL ABEDIN(RELPG,LNGTHG,LNBR,RNBR,
     +  NGELS,NCONTS,SEQ3,LINCON(LMOST),JOINT(LMOST),SEQC2(1,LMOST),
     +  ITOTPC(LMOST),IDOUT(LMOST),IDBSIZ,IDEV,IDEV1,IDEV2,
     +  MAXGEL)
      END IF
      JOINT(RMOST)=1
      IDOUT(RMOST)=ILC(RMOST)
      IF(ITOTPC(RMOST).GT.0)THEN
        WRITE(IDEV,1017)LLINO(RMOST)
        CALL ABEDIN(RELPG,LNGTHG,LNBR,RNBR,
     +  NGELS,NCONTS,SEQ3,LINCON(RMOST),JOINT(RMOST),SEQC2(1,RMOST),
     +  ITOTPC(RMOST),IDOUT(RMOST),IDBSIZ,IDEV,IDEV1,IDEV2,
     +  MAXGEL)
      END IF
      ILC(RMOST)=ILCR
      LTL=LNBR(LINCON(LMOST))
      LTR=LNBR(LINCON(RMOST))
      WRITE(IDEV,1018)LNBR(LINCON(LMOST)),LNBR(LINCON(RMOST))
1018  FORMAT(' Completing the join between contigs',I6,' and',I6)
      CALL AJOIN2(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +JOINT(LMOST),LTL,LTR,LINCON(LMOST),LINCON(RMOST),IDEV1)
      LLINO(1)=LTL
      IF(ILEFTS(LMOST).GT.ILEFTS(RMOST))THEN
        CALL DELCON(SEQ1,ILEFTS(LMOST),ILC(LMOST),IDIM1)
        CALL DELCON(SEQ1,ILEFTS(RMOST),ILC(RMOST),IDIM1)
      END IF
      IF(ILEFTS(RMOST).GE.ILEFTS(LMOST))THEN
        CALL DELCON(SEQ1,ILEFTS(RMOST),ILC(RMOST),IDIM1)
        CALL DELCON(SEQ1,ILEFTS(LMOST),ILC(LMOST),IDIM1)
      END IF
      LREG=1
      RREG=JOINT(LMOST)
      IGELC=LLINO(1)
      JOB = 1
      CALL ACONSN(RELPG,LNGTHG,LNBR,RNBR,NAMPRO,NGELS,NCONTS,
     +SEQ1,MAXSEQ,SEQ2,IDBSIZ,IDIM1,JOB,IGELC,LREG,RREG,TEMP3,
     +ECHRSZ,MAXGL2,IDEV,IDEV2,IFAIL(1),MAXGEL,IDM,PERCD)
      IF(IFAIL(1).NE.0) THEN
        CALL ERROM(KBOUT,'Error calculating consensus')
        GO TO 900
      END IF
C      CALL FMTDB(SEQ1,IDIM1,1,IDIM1,60,IDEV)
      JNJOIN = JNJOIN + 1
      IF(KFAIL.NE.0) THEN
C        CALL AERROR(IDEV,IDEV8,NAMARC,4)
C        JOINF = JOINF + 1
      END IF
      GO TO 1
900   CONTINUE
C      CALL FMTDB(SEQ1,IDIM1,1,IDIM1,60,IDEV)
      WRITE(KBOUT,*)'Batch finished'
      WRITE(KBOUT,*)JGEL,' sequences processed'
      WRITE(KBOUT,*)JNGEL,' sequences entered into database'
      WRITE(KBOUT,*)JNJOIN,' joins made'
      WRITE(KBOUT,*)JOINF, ' joins failed'
      END
      SUBROUTINE DBAUTP(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +SEQ2,NAMARC,JOINT,ITYPE,ISENSE,SEQC2,ITOTPC,
     +IDIM2,IDOUT,LLINO,LINCON,IFAIL,IDBSIZ,MAXDB,IDEV,
     +IDEV1,IDEV2,IDEV3,IDEVT,IDEVC,IDEV4,MAXGEL,IMATC,IEMPTY,IOPT)
      INTEGER RELPG(MAXDB)
      INTEGER LNGTHG(MAXDB),LNBR(MAXDB),RNBR(MAXDB)
      CHARACTER SEQ2(MAXGEL),SEQC2(MAXGEL)
      CHARACTER NAMARC*(*)
C  deals with entering all readings into contig 1 (IOPT=2)
C  or all readings into new contigs (IOPT=3)
      IF(IOPT.EQ.2) THEN
        IF(IMATC.EQ.0) THEN
          ITYPE=0
          ISENSE=1
          IDOUT=MAXGEL
          CALL AENTER(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +    SEQ2,NAMARC,JOINT,ITYPE,ISENSE,SEQC2,ITOTPC,
     +    IDIM2,IDOUT,LLINO,LINCON,IFAIL,IDBSIZ,IDEV,
     +    IDEV1,IDEV2,IDEV3,IDEVT,IDEVC,IDEV4,MAXGEL)
          IF(IFAIL.NE.0) RETURN
          IEMPTY=0
          IMATC = 1
        ELSE
          ITYPE= - 1
          ISENSE=1
          JOINT = 1
          LLINO = 1
          LINCON = IDBSIZ - 1
          ITOTPC = 0
          IDOUT=MAXGEL
          CALL AENTER(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +    SEQ2,NAMARC,JOINT,ITYPE,ISENSE,SEQC2,ITOTPC,
     +    IDIM2,IDOUT,LLINO,LINCON,IFAIL,IDBSIZ,IDEV,
     +    IDEV1,IDEV2,IDEV3,IDEVT,IDEVT,IDEV4,MAXGEL)
          IF(IFAIL.NE.0) RETURN
        END IF
      ELSE IF(IOPT.EQ.3) THEN
        ITYPE=0
        ISENSE=1
        IDOUT=MAXGEL
        CALL AENTER(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +    SEQ2,NAMARC,JOINT,ITYPE,ISENSE,SEQC2,ITOTPC,
     +    IDIM2,IDOUT,LLINO,LINCON,IFAIL,IDBSIZ,IDEV,
     +    IDEV1,IDEV2,IDEV3,IDEVT,IDEVC,IDEV4,MAXGEL)
        IF(IFAIL.NE.0) RETURN
      END IF
      END
      SUBROUTINE DBCOPY(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,GEL,
     +NAMPRO,IDEV,IDBSIZ,IERR,KBIN,KBOUT,IDEVR,IDEVW,IDEVN,
     +IDEVT,IDEVC,
     +IHELPS,IHELPE,FILEH,IDEVH,MAXGEL,MAXDB,IDM)
      CHARACTER FILEH*(*)
C   AUTHOR: RODGER STADEN
      INTEGER RELPG(IDBSIZ)
      INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
      CHARACTER NAMPRO*(*),NAMARC*16,GEL(MAXGEL)
      CHARACTER V2,V1,VIN
      INTEGER IWORD,DELDB,ACTF
      PARAMETER (IWORD=4)
      PARAMETER (MAXPRM = 21)
      CHARACTER PERR(2)*(MAXPRM)
      EXTERNAL DELDB,ACTF
      IERR=1
      LL = INDEX(NAMPRO,'.')
C
C save incoming version
C
      VIN = NAMPRO(LL+1:LL+1)
1     CONTINUE
      L = 1
      V1='1'
      CALL GTSTR('Make version',V1,V2,L,KBOUT,KBIN,INFLAG)
      CALL CCASE(V2,1)
      IF(INFLAG.EQ.2) RETURN
      IF(INFLAG.EQ.1) THEN
        CALL HELP2(IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
        GO TO 1
      END IF
      IF(L.LT.1) V2 = V1
C
C check if file is open
C
      NAMPRO(LL+1:LL+1) = V2
      LM1 = LL - 1
      IOK = ACTF(1,NAMPRO,LM1,V2,KBOUT)
      IF (IOK.NE.0) THEN
        NAMPRO(LL+1:LL+1) = VIN
        RETURN
      END IF
      MN = NGELS + NCONTS + 1
      MX = MAXDB
      NEWSIZ = IDBSIZ
      CALL GETINT(MN,MX,NEWSIZ,
     +'New database size',
     +IVAL,KBIN,KBOUT,IHELPS,IHELPE,FILEH,IDEVH,IOK)
      IF(IOK.NE.0) GO TO 40
      CALL BUSY(KBOUT)
      NEWSIZ = IVAL
C     WHERE SHOULD CHARS BE CHANGED ?
      LLL = INDEX(NAMPRO,'.') + 1
      NAMPRO(LLL:)='RL'//V2
      CALL OPENRS(IDEV,NAMPRO,IOK,4,3)
      IF(IOK.NE.0) THEN
C problem opening file
        IF(IOK.EQ.2) THEN
          CALL ERROM(KBOUT,'File already exists')
          PERR(1) = 'Retype version number'
          PERR(2) = 'Replace database'
          IDO = 1
          CALL RADION('Select action',PERR,2,IDO,
     +    IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
          IF(IDO.LT.1) GO TO 40
          IF(IDO.EQ.1) THEN
C
C close busy file (note we dont care what we send for job=2!!!)
C
            NAMPRO(LL+1:LL+1) = V2
            IOK = ACTF(2,NAMPRO,LLL,V2,KBOUT)
            IF (IOK.NE.0) THEN
C should never get here
              NAMPRO(LL+1:LL+1) = VIN
              RETURN
            END IF
            GO TO 1
          END IF
          IF(IDO.EQ.2) THEN
            IOK =  DELDB(NAMPRO,V2,IDEV,MAXGEL)
            IF(IOK.EQ.0) THEN
              LLL = INDEX(NAMPRO,'.') + 1
              NAMPRO(LLL:)='RL'//V2
              CALL OPENRS(IDEV,NAMPRO,IOK,4,3)
              IF(IOK.EQ.0) GO TO 2
            ELSE
              CALL ERROM(KBOUT,'File delete failed')
            END IF
          END IF
        END IF
        GO TO 100
      END IF
 2    CONTINUE
      CALL WRITER(IDEV,0,MAXDB,NEWSIZ,MAXGEL,IDM)
      CALL WRITER(IDEV,NEWSIZ,NGELS,NCONTS,NGELS,NCONTS)
      DO 10 I=1,NGELS
        CALL WRITER(IDEV,I,RELPG(I),LNGTHG(I),LNBR(I),RNBR(I))
10    CONTINUE
      M=NEWSIZ-NCONTS
      N=IDBSIZ-NCONTS
      DO 15 I=N,IDBSIZ-1
        CALL WRITER(IDEV,M,RELPG(I),LNGTHG(I),LNBR(I),RNBR(I))
        M=M+1
15    CONTINUE
      CLOSE(UNIT=IDEV)
C  DO SEQUENCES
      NAMPRO(LLL:)='SQ'//V2
      IREC=MAXGEL/IWORD
      IF(MOD(MAXGEL,IWORD).NE.0)IREC=IREC+1
      CALL OPENRS(IDEV,NAMPRO,IOK,IREC,3)
      IF(IOK.NE.0)GO TO 100
      DO 20 I=1,NGELS
        CALL READW(IDEVW,I,GEL,MAXGEL)
        CALL WRITEW(IDEV,I,GEL,MAXGEL)
20    CONTINUE
      CLOSE(UNIT=IDEV)
C   DO ARCHIVE NAMES
      NAMPRO(LLL:)='AR'//V2
       CALL OPENRS(IDEV,NAMPRO,IOK,4,3)
      IF(IOK.NE.0)GO TO 100
      DO 30 I=1,NGELS
        CALL READN(IDEVN,I,NAMARC)
        CALL WRITEN(IDEV,I,NAMARC)
30    CONTINUE
      CLOSE(UNIT=IDEV)
      IF(IDEVT.GT.0.AND.IDEVC.GT.0) THEN
        NAMPRO(LLL:)='TG'//V2
        CALL OPENRS(IDEV,NAMPRO,IOK,5,3)
        IF(IOK.NE.0)GO TO 100
        CALL COPYTG(IDEVT,IDEV,IOK,IDBSIZ,NEWSIZ,NGELS)
        CLOSE(UNIT=IDEV)
        NAMPRO(LLL:)='CC'//V2
C  COMMENT_LENGTH: 11 = (40 + long)/long
        CALL OPENRS(IDEV,NAMPRO,IOK,11,3)
        IF(IOK.NE.0)GO TO 100
        CALL COPYCC(IDEVC,IDEV,IOK)
        CLOSE(UNIT=IDEV)
      ENDIF
      IERR=0
 40   CONTINUE
C
C close busy file (note we dont care what we send for job=2!!!)
C
      LL = INDEX(NAMPRO,'.')
      NAMPRO(LL+1:LL+1) = V2
      IOK = ACTF(2,NAMPRO,LL,V2,KBOUT)
      NAMPRO(LL+1:LL+1) = VIN
      RETURN
100   CONTINUE
      WRITE(KBOUT,9999)
9999  FORMAT(' Error opening new database, copy aborted')
C
C close busy file
C
      LL = INDEX(NAMPRO,'.')
      NAMPRO(LL+1:LL+1) = V2
      IOK = ACTF(2,NAMPRO,LL,V2,KBOUT)
      NAMPRO(LL+1:LL+1) = VIN
      END
      INTEGER FUNCTION DELDB(NAMPRO,VERSN,IDEV,MAXGEL)
      CHARACTER NAMPRO*(*),VERSN
      INTEGER DELF
      EXTERNAL DELF
C
C delete an xdap database (bap): names are 16 characters!
C
C assume relationships are 4 words, names are 4 and seqs are maxgel
C all recls in BYTES
C
      DELDB = 1
      LLL = INDEX(NAMPRO,'.') + 1
      NAMPRO(LLL:)='RL'//VERSN
      IF(DELF(NAMPRO,IDEV,16,4).NE.0) RETURN
      NAMPRO(LLL:)='AR'//VERSN
      IF(DELF(NAMPRO,IDEV,16,4).NE.0) RETURN
      NAMPRO(LLL:)='SQ'//VERSN
      IF(DELF(NAMPRO,IDEV,MAXGEL,4).NE.0) RETURN
      NAMPRO(LLL:)='CC'//VERSN
C  COMMENT_LENGTH: 11 = (40 + long)/long
      IF(DELF(NAMPRO,IDEV,44,4).NE.0) RETURN
      NAMPRO(LLL:)='TG'//VERSN
      IF(DELF(NAMPRO,IDEV,20,4).NE.0) RETURN
      DELDB = 0
      END
      SUBROUTINE DBFIX(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +GEL,GEL2,IDBSIZ,KBIN,KBOUT,IDEVR,IDEVW,IDEVN,
     +IHELPS,IHELPE,IHELP1,IHELP2,FILEH,IDEVH,MAXGEL,MAXGLM,
     +IDEVT,IDEVC,TEMP)
      CHARACTER FILEH*(*)
C   AUTHOR: RODGER STADEN
C  12-12-90 Added function to change raw data parameter file
C  and changed menu routines accordingly
      INTEGER RELPG(IDBSIZ),X,TEMP(IDBSIZ)
      INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
      CHARACTER GEL(MAXGEL)
      CHARACTER NAME*16,NEWNAM*16
      INTEGER L,M,N
      CHARACTER GEL2(MAXGEL)
      PARAMETER (MAXPRM = 32)
      CHARACTER PROMPT(9)*(MAXPRM)
      INTEGER GCLIN,CHAINL
      EXTERNAL GCLIN,CHAINL
      WRITE(KBOUT,1000)
1000  FORMAT(
     +' Warning:',
     +' make a copy first, and check logical consistency after use')
10    CONTINUE
C
C   SELECT OPTION
C      CALL BELL(1,KBOUT)
C     DBMENU now defunct for bap - so we use RADION instead
C      CALL DBMENU(4,NOPT,KOPT,IHELPS,IHELPE,FILEH,IDEVH,
C     +KBIN,KBOUT)
      PROMPT(1) = 'Line change'
      PROMPT(2) = 'Check logical consistency'
      PROMPT(3) = 'Delete contig line'
      PROMPT(4) = 'Shift'
      PROMPT(5) = 'Move gel reading'
      PROMPT(6) = 'Rename gel reading'
      PROMPT(7) = 'Break a contig'
      PROMPT(8) = 'Remove a gel reading'
      PROMPT(9) = 'Alter raw data parameters'
      NOPT = 1
      CALL RADION('Alter relationships', PROMPT, 9, NOPT, IHELPS,
     +  IHELPE, FILEH, IDEVH, KBIN, KBOUT)
      IF(NOPT.LT.1)RETURN
      IF(NOPT.EQ.1)THEN
C       LINE CHANGE
        MN = 0
        MX = IDBSIZ
        LNO = 0
        CALL GETINT(MN,MX,LNO,
     +  'Number of line to change',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) GO TO 10
        IF(IVAL.EQ.0) GO TO 18
        LNO = IVAL
        IF(LNO.EQ.IDBSIZ)GO TO 19
        WRITE(KBOUT,*)'Current line'
        WRITE(KBOUT,1001)RELPG(LNO),LNGTHG(LNO),LNBR(LNO),RNBR(LNO)
1001    FORMAT(' ',4I6)
        MN = 0
        MX = 99999
        X  = RELPG(LNO)
        CALL GETINT(MN,MX,X,
     +  'Relative position',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) GO TO 10
        X = IVAL
        MN = -MAXGEL
        MX = 999999
        L  = LNGTHG(LNO)
        CALL GETINT(MN,MX,L,
     +  'Length',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) GO TO 10
        L = IVAL
        MN = 0
        MX = IDBSIZ
        M  = LNBR(LNO)
        CALL GETINT(MN,MX,M,
     +  'Left neighbour',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) GO TO 10
        M = IVAL
        MN = 0
        MX = IDBSIZ
        N  = RNBR(LNO)
        CALL GETINT(MN,MX,N,
     +  'Right neighbour',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        N = IVAL
        CALL WRITER(IDEVR,LNO,X,L,M,N)
        RELPG(LNO)=X
        LNGTHG(LNO)=L
        LNBR(LNO)=M
        RNBR(LNO)=N
        GO TO 10
 18     CONTINUE
C
C deal with record 1/0 which contains: maxdb,actualdbsiz,maxgel,idm
C
        WRITE(KBOUT,*)
     +  'Extreme caution: after this record is changed the program'
        WRITE(KBOUT,*)
     +  'should be restarted, and could malfunction!'
        CALL READR(IDEVR,0,IMSIZ,IASIZ,MXG,IDA)
        WRITE(KBOUT,*)'Current line'
        WRITE(KBOUT,1001)IMSIZ,IASIZ,MXG,IDA
        MN = 0
        MX = 999999
        X  = IMSIZ
        CALL GETINT(MN,MX,X,
     +  'Maximum database size',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) GO TO 10
        X = IVAL
        MN = 0
        MX = X
        L  = IASIZ
        CALL GETINT(MN,MX,L,
     +  'Actual database size',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) GO TO 10
        L = IVAL
        MN = 0
        MX = MAXGLM
        M  = MXG
        CALL GETINT(MN,MX,M,
     +  'Maximum reading length',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) GO TO 10
        M = IVAL
        ID = 0
        IF(IDA.EQ.26) ID = 1
        CALL YESONO(ID,'Database is for DNA',
     +  'Database is for protein',
     +  IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
        IF(ID.LT.0) GO TO 10
        N = 5
        IF(ID.EQ.0)N = 5
        IF(ID.EQ.1)N = 26
        CALL WRITER(IDEVR,0,X,L,M,N)
        GO TO 10
19      CONTINUE
C       NCONTS NGELS LINES
        MN = 0
        MX = IDBSIZ
        LL = NGELS
        CALL GETINT(MN,MX,LL,
     +  'Number of gel readings',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) GO TO 10
        LL = IVAL
        MN = 0
        MX = IDBSIZ
        MM  = NCONTS
        CALL GETINT(MN,MX,MM,
     +  'Number of contigs',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) GO TO 10
        MM = IVAL
        CALL WRITER(IDEVR,IDBSIZ,LL,MM,LL,MM)
        NGELS=LL
        NCONTS=MM
        GO TO 10
      END IF
C
C
      IF(NOPT.EQ.4)THEN
        MN = 0
        MX = NGELS
        LNO  = 0
        CALL GETINT(MN,MX,LNO,
     +  'Number of first gel reading to shift',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) GO TO 10
        IF(IVAL.LT.1) GO TO 10
        LNO = IVAL
        I = CHAINL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +  IDBSIZ,LNO)
        IF(I.EQ.0)THEN
          WRITE(KBOUT,*)
     +    'Problem with this gel reading. Check logical consistency'
          WRITE(KBOUT,*)'of database. Shift not done'
          GO TO 10
        END IF
        NCONTO = GCLIN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +  IDBSIZ,I)
        IF(NCONTO.EQ.0)THEN
          WRITE(KBOUT,*)
     +    'No contig line for this contig. Check logical'
          WRITE(KBOUT,*)'consistency of database. Shift not done'
          GO TO 10
        END IF
        MN = 1 - RELPG(LNO)
        MX  = RELPG(NCONTO) - RELPG(LNO)
        X = MN
        CALL GETINT(MN,MX,X,
     +  'Distance to shift',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        X = IVAL
        CALL SHIFTC(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDEVR,
     +  IDBSIZ,LNO,NCONTO,X)
        WRITE(KBOUT,*)'Shift complete'
        GO TO 10
      END IF
C
      IF (NOPT.EQ.2) THEN
        CALL DBCHEK(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +  TEMP,IERR,KBOUT)
        GO TO 10
      END IF
      IF(NOPT.EQ.3)THEN
        WRITE(KBOUT,*)'Remove a contig'
        MN = 0
        MX = NGELS
        LNO  = 0
        CALL GETINT(MN,MX,LNO,
     +  'Number of a reading in the contig to delete',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) GO TO 10
        IF(IVAL.EQ.0) GO TO 10
        LNO = IVAL
        I = CHAINL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +    IDBSIZ,LNO)
        ICONT = GCLIN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,I)
        IF(ICONT.EQ.0) THEN
          WRITE(KBOUT,*)'No contig line for this reading'
          GO TO 10
        END IF
        CALL REMCON(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +  ICONT,GEL,I,IDEVR,IDEVW,IDEVN,MAXGEL,KBOUT,TEMP)
      END IF
      IF(NOPT.EQ.6)THEN
        MN = 0
        MX = NGELS
        LNO  = 0
        CALL GETINT(MN,MX,LNO,
     +  'Number of gel reading to rename',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) GO TO 10
        IF(IVAL.LT.1) GO TO 10
        LNO = IVAL
        CALL READN(IDEVN,LNO,NAME)
        L = 16
        CALL GTSTR('name for gel reading',
     +  NAME,NEWNAM,L,KBOUT,KBIN,INFLAG)
        IF(L.GT.0)CALL WRITEN(IDEVN,LNO,NEWNAM)
        GO TO 10
      END IF
      IF(NOPT.EQ.5)THEN
        MN = 0
        MX = NGELS
        IFROM  = 0
        CALL GETINT(MN,MX,IFROM,
     +  'Number of gel reading to move',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) GO TO 10
        IF(IVAL.LT.1) GO TO 10
        IFROM = IVAL
        MN = 0
        MX = NGELS
        ITO  = 0
        CALL GETINT(MN,MX,ITO,
     +  'New number for gel reading',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) GO TO 10
        IF(IVAL.LT.1) GO TO 10
        ITO = IVAL
        CALL MOVGEL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +  GEL,IFROM,ITO,IDEVR,IDEVW,IDEVN,MAXGEL,KBOUT)
        GO TO 10
      END IF
      IF(NOPT.EQ.7)THEN
        CALL BREAKC(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +  IDBSIZ,KBIN,KBOUT,IDEVR,IDEVW,IDEVN,
     +  IHELPS,IHELPE,IHELP1,IHELP2,FILEH,IDEVH,IOK)
        GO TO 10        
      END IF
      IF(NOPT.EQ.8) THEN
        CALL REMGD(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +  KBIN,KBOUT,GEL,MAXGEL,IDEVR,IDEVW,IDEVN,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        GO TO 10
      END IF
      IF(NOPT.EQ.9) THEN
        CALL FIXRD(IDEVT,IDEVC,IDBSIZ,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH)
        GO TO 10
      END IF
      GO TO 10
      END
      SUBROUTINE REMCON(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +ICONT,GEL,LLINO,IDEVR,IDEVW,IDEVN,MAXGEL,KBOUT,TEMP)
C   AUTHOR: RODGER STADEN
      INTEGER RELPG(IDBSIZ),TEMP(IDBSIZ)
      INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
      CHARACTER GEL(MAXGEL)
C
C problem is to remove a contig. Strategy is to find all its read numbers
C and store them in temp. Then go thru and replace them by reads from the
C end of the list of reads. An earlier version tried to chain thru but
C ran into complications about replacing reads by reads they pointed to!
C
      DO 10 I=1,IDBSIZ
        TEMP(I) = 0
 10     CONTINUE
C
      NDEL = 0
      I = LLINO
 20   CONTINUE
      TEMP(I) = 1
      NDEL = NDEL + 1
      IF (RNBR(I).NE.0) THEN
        I = RNBR(I)
        GO TO 20
      END IF
C
C now in temp all the reads in the contig are 1, the rest of temp is zero
C let i be the read to move and j the last read left in the list of reads
C so if temp(i) is 1 and temp(j) is zero move read j to i and set j = j - 1
C then deal with the next i.
C if temp(i) is 1 and temp(j) is also 1 simply set j = j - 1 and try to move
C that one
C we stop when weve gone so far along the list that the next read to
C delete is equal to the number of reads left in the list
C
C what are the difficult cases? 
C 1. only one contig
C 2. all reads to right of llino are are near the end of the list of reads
C
      I = 1
      J = NGELS
 30   CONTINUE
      IF (TEMP(I).EQ.1) THEN
        IF (TEMP(J).EQ.0) THEN
          WRITE(*,*)'MOVE ',J,' TO ',I
          CALL MOVGEL(RELPG,LNGTHG,LNBR,RNBR,J,NCONTS,IDBSIZ,
     +    GEL,J,I,IDEVR,IDEVW,IDEVN,MAXGEL,KBOUT)
          J = J - 1
        ELSE
          J = J - 1
          IF (I.LT.J) GO TO 30
        END IF
      END IF
      IF (I.LT.J) THEN
        I = I + 1
        GO TO 30
      END IF
C
C fix up number of reads and the contig record
C
      NGELS = NGELS - NDEL
      CALL REMCNL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +ICONT,IDEVR)
      END
      SUBROUTINE REMGD(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +KBIN,KBOUT,GEL,MAXGEL,IDEVR,IDEVW,IDEVN,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      INTEGER RELPG(IDBSIZ),LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
      CHARACTER HELPF*(*),GEL(MAXGEL)
      INTEGER REMME,GCLIN,CHAINL
      EXTERNAL GCLIN,CHAINL
C assumes db is logical consistent
      WRITE(KBOUT,*)'Remove reading from database'
      REMME = NGELS
      CALL GETINT(1,NGELS,REMME,
     +'Number of reading to remove',
     +IVAL,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      REMME = IVAL
      I = CHAINL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +    IDBSIZ,REMME)
      ICONT = GCLIN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,I)
      IF(ICONT.EQ.0) THEN
        WRITE(KBOUT,*)'No contig line for this reading'
        IOK = 1
        RETURN
      END IF
      CALL REMGEL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +REMME,ICONT,KBOUT,GEL,MAXGEL,IDEVR,IDEVW,IDEVN)
      END
      SUBROUTINE REMGEL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +REMME,ICONT,KBOUT,GEL,MAXGEL,IDEVR,IDEVW,IDEVN)
C Routine to remove a reading from a database
C Cases: 1 left end
C        2 right end
C        3 internal and dispensible
C        4 internal and indispensible
C if 1 change contig lnbr, contig length, lnbr of rnbr of remme, relpgs
C if 2 change contig rnbr, contig length, rnbr of lnbr of remme
C if 3 change contig length, lnbr of rnbr of remme rnbr of lnbr of remme
C if 4 need to break contig, then as for 1
C if 1 and 2 then also remove contig line
C for all cases move gel ngels to remme (if remme/=ngels)
C and update line idbsiz
C
      INTEGER RELPG(IDBSIZ),LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
      INTEGER REMME,CLEN
      LOGICAL LEFTE,RIGHTE,DISPEN
      CHARACTER GEL(MAXGEL)
      EXTERNAL CLEN
      LEFTE = .FALSE.
      RIGHTE = .FALSE.
      DISPEN = .FALSE.
C
C Left end ?
C
      IF(LNBR(REMME).EQ.0) LEFTE = .TRUE.
C
C Right end ?
C
      IF(RNBR(REMME).EQ.0) RIGHTE = .TRUE.
C
C If both true remove the contig line, then overwrite the gel
C     
      IF(LEFTE.AND.RIGHTE) THEN
        WRITE(KBOUT,*)'Removing reading and contig'
        IFROM = NGELS
        NGELS = NGELS - 1
        CALL REMCNL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +  ICONT,IDEVR)
        IF(REMME.NE.IFROM) THEN
          WRITE(KBOUT,*)'Renumbering reading',IFROM,' to',REMME
          CALL MOVGEL(RELPG,LNGTHG,LNBR,RNBR,NGELS,
     +    NCONTS,IDBSIZ,GEL,IFROM,REMME,IDEVR,IDEVW,IDEVN,MAXGEL,KBOUT)
        END IF
      ELSE IF(LEFTE) THEN
        WRITE(KBOUT,*)'Removing reading from left end of contig'
        LNBR(ICONT) = RNBR(REMME)
        I = 1 - RELPG(RNBR(REMME))
        WRITE(KBOUT,*)'Shifting readings in contig by distance=',I
        CALL SHIFTC(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDEVR,
     +  IDBSIZ,RNBR(REMME),ICONT,I)
        I = LNBR(ICONT)
        LNBR(I) = 0
        CALL WRITER(IDEVR,I,RELPG(I),LNGTHG(I),
     +  LNBR(I),RNBR(I))
        IFROM = NGELS
        IF(REMME.NE.IFROM) THEN
          WRITE(KBOUT,*)'Renumbering reading',IFROM,' to',REMME
          CALL MOVGEL(RELPG,LNGTHG,LNBR,RNBR,NGELS,
     +    NCONTS,IDBSIZ,GEL,IFROM,REMME,IDEVR,IDEVW,IDEVN,MAXGEL,KBOUT)
        END IF
        NGELS = NGELS - 1
        CALL WRITER(IDEVR,IDBSIZ,NGELS,NCONTS,NGELS,NCONTS)
      ELSE IF(RIGHTE) THEN
        WRITE(KBOUT,*)'Removing reading from right end of contig'
        RNBR(ICONT) = LNBR(REMME)
        I = RNBR(ICONT)
        RNBR(I) = 0
        CALL WRITER(IDEVR,I,RELPG(I),LNGTHG(I),
     +  LNBR(I),RNBR(I))
        RELPG(ICONT) = CLEN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +  IDBSIZ,LNBR(ICONT))
        CALL WRITER(IDEVR,ICONT,RELPG(ICONT),LNGTHG(ICONT),
     +  LNBR(ICONT),RNBR(ICONT))
        IFROM = NGELS
        IF(REMME.NE.IFROM) THEN
          WRITE(KBOUT,*)'Renumbering reading',IFROM,' to',REMME
          CALL MOVGEL(RELPG,LNGTHG,LNBR,RNBR,NGELS,
     +    NCONTS,IDBSIZ,GEL,IFROM,REMME,IDEVR,IDEVW,IDEVN,MAXGEL,KBOUT)
        END IF
        NGELS = NGELS - 1
        CALL WRITER(IDEVR,IDBSIZ,NGELS,NCONTS,NGELS,NCONTS)
      ELSE
C Is remme indispensible ?
        NSTART = RELPG(RNBR(REMME))
        I = REMME
10      CONTINUE
        I = LNBR(I)
        IF(I.NE.0) THEN
          IF((RELPG(I)+ABS(LNGTHG(I))-1).LT.NSTART) GO TO 10
          DISPEN = .TRUE.
        END IF
        IF(DISPEN) THEN
          WRITE(KBOUT,*)
     +    'Removing dispensible reading from middle of contig'
          I = LNBR(REMME)
          RNBR(I) = RNBR(REMME)
          CALL WRITER(IDEVR,I,RELPG(I),LNGTHG(I),
     +    LNBR(I),RNBR(I))
          I = RNBR(REMME)
          LNBR(I) = LNBR(REMME)
          CALL WRITER(IDEVR,I,RELPG(I),LNGTHG(I),
     +    LNBR(I),RNBR(I))
          IFROM = NGELS
          IF(REMME.NE.IFROM) THEN
            WRITE(KBOUT,*)'Renumbering reading',IFROM,' to',REMME
            CALL MOVGEL(RELPG,LNGTHG,LNBR,RNBR,NGELS,
     +      NCONTS,IDBSIZ,GEL,IFROM,REMME,IDEVR,IDEVW,IDEVN,
     +      MAXGEL,KBOUT)
          END IF
          NGELS = NGELS - 1
          RELPG(ICONT) = CLEN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +    IDBSIZ,LNBR(ICONT))
          CALL WRITER(IDEVR,ICONT,RELPG(ICONT),LNGTHG(ICONT),
     +    LNBR(ICONT),RNBR(ICONT))
          CALL WRITER(IDEVR,IDBSIZ,NGELS,NCONTS,NGELS,NCONTS)
        ELSE
          WRITE(KBOUT,*)
     +    'Removing indispensible reading from middle of contig'
          WRITE(KBOUT,*)'So breaking contig first'
          IR = REMME
          IL = LNBR(REMME)
          ILO = LNBR(ICONT)
          NCONTO = ICONT
          NCONTR = IDBSIZ - NCONTS - 1
          CALL CBREAK(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +    KBOUT,IDEVR,IDEVW,IDEVN,IR,IL,ILO,NCONTO,NCONTR,IOK)
          IF(IOK.NE.0) RETURN
          WRITE(KBOUT,*)'Removing reading from left end of contig'
          ICONT = IDBSIZ - NCONTS
          LNBR(ICONT) = RNBR(REMME)
          I = 1 - RELPG(RNBR(REMME))
          WRITE(KBOUT,*)'Shifting readings in contig by distance=',I
          CALL SHIFTC(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDEVR,
     +    IDBSIZ,RNBR(REMME),ICONT,I)
          I = LNBR(ICONT)
          LNBR(I) = 0
          CALL WRITER(IDEVR,I,RELPG(I),LNGTHG(I),
     +    LNBR(I),RNBR(I))
          IFROM = NGELS
          IF(REMME.NE.IFROM) THEN
            WRITE(KBOUT,*)'Renumbering reading',IFROM,' to',REMME
            CALL MOVGEL(RELPG,LNGTHG,LNBR,RNBR,NGELS,
     +      NCONTS,IDBSIZ,GEL,IFROM,REMME,IDEVR,IDEVW,IDEVN,
     +      MAXGEL,KBOUT)
          END IF
          NGELS = NGELS - 1
          CALL WRITER(IDEVR,IDBSIZ,NGELS,NCONTS,NGELS,NCONTS)
        END IF
      END IF
      END
      SUBROUTINE REMCNL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +REMME,IDEVR)
      INTEGER RELPG(IDBSIZ),LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
      INTEGER REMME
C Routine to remove a contig line from a db
C Loop deals with case of remove top contig
C Move down all lines from above
      DO 10 I = REMME,IDBSIZ-NCONTS+1,-1
        RELPG(I) = RELPG(I-1)
        LNGTHG(I) = LNGTHG(I-1)
        LNBR(I) = LNBR(I-1)
        RNBR(I) = RNBR(I-1)
        CALL WRITER(IDEVR,I,RELPG(I),LNGTHG(I),LNBR(I),RNBR(I))
10    CONTINUE
      NCONTS = NCONTS - 1
      CALL WRITER(IDEVR,IDBSIZ,NGELS,NCONTS,NGELS,NCONTS)
      END
      SUBROUTINE MOVGEL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +GEL,FROM,TO,IDEVR,IDEVW,IDEVN,MAXGEL,KBOUT)
C   Subroutine to move a gel from line from to line to
C   Extended 22-5-91
C   AUTHOR: RODGER STADEN
      INTEGER RELPG(IDBSIZ),FROM,TO
      INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
      CHARACTER NAMGEL*16,GEL(MAXGEL)
      INTEGER GCLIN,CHAINL
      LOGICAL LEFTE,RIGHTE
      EXTERNAL GCLIN,CHAINL
      LEFTE = .FALSE.
      RIGHTE = .FALSE.
C
C left end ?
C
      IF(LNBR(FROM).EQ.0) LEFTE = .TRUE.
C
C right end ?
C
      IF(RNBR(FROM).EQ.0) RIGHTE = .TRUE.
C
C if both true remove the contig line, then overwrite the gel
C     
      IF(LEFTE.AND.RIGHTE) THEN
        NCONTO = GCLIN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +    IDBSIZ,FROM)
        IF(NCONTO.EQ.0)THEN
          WRITE(KBOUT,*)
     +      'This gel has no left neighbour but does not'
            WRITE(KBOUT,*)'appear in a contig line!'
        ELSE
          LNBR(NCONTO) = TO
          RNBR(NCONTO) = TO
          CALL WRITER(IDEVR,NCONTO,RELPG(NCONTO),LNGTHG(NCONTO),
     +      LNBR(NCONTO),RNBR(NCONTO))
        END IF
      ELSE IF(LEFTE) THEN
        NCONTO = GCLIN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +    IDBSIZ,FROM)
        IF(NCONTO.EQ.0)THEN
          WRITE(KBOUT,*)
     +      'This gel has no left neighbour but does not'
            WRITE(KBOUT,*)'appear in a contig line!'
        ELSE
          LNBR(NCONTO) = TO
          CALL WRITER(IDEVR,NCONTO,RELPG(NCONTO),LNGTHG(NCONTO),
     +      LNBR(NCONTO),RNBR(NCONTO))
        END IF
      ELSE IF(RIGHTE) THEN
        I = CHAINL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +    IDBSIZ,FROM)
        NCONTO = GCLIN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +    IDBSIZ,I)
        IF(NCONTO.EQ.0)THEN
          WRITE(KBOUT,*)
     +      'This gel has no right neighbour and does not'
          WRITE(KBOUT,*)'appear in a contig!'
        ELSE
          IF(RNBR(NCONTO).NE.FROM)THEN
            WRITE(KBOUT,*)
     +        'This gel has no right neighbour but does not'
            WRITE(KBOUT,*)'appear in a contig line!'
          ELSE
            RNBR(NCONTO) = TO
            CALL WRITER(IDEVR,NCONTO,RELPG(NCONTO),LNGTHG(NCONTO),
     +        LNBR(NCONTO),RNBR(NCONTO))
          END IF
        END IF
      END IF
      RELPG(TO)=RELPG(FROM)
      LNGTHG(TO)=LNGTHG(FROM)
      LNBR(TO)=LNBR(FROM)
      RNBR(TO)=RNBR(FROM)
      CALL READW(IDEVW,FROM,GEL,MAXGEL)
      CALL WRITEW(IDEVW,TO,GEL,MAXGEL)
      CALL READN(IDEVN,FROM,NAMGEL)
      CALL WRITEN(IDEVN,TO,NAMGEL)
      CALL WRITER(IDEVR,TO,RELPG(TO),LNGTHG(TO),
     +LNBR(TO),RNBR(TO))
C   Do neighbours
      IF(LNBR(FROM).NE.0) THEN
        I=LNBR(FROM)
        RNBR(I)=TO
        CALL WRITER(IDEVR,I,RELPG(I),LNGTHG(I),
     +  LNBR(I),RNBR(I))
      END IF
      IF(RNBR(FROM).NE.0) THEN
        I=RNBR(FROM)
        LNBR(I)=TO
        CALL WRITER(IDEVR,I,RELPG(I),LNGTHG(I),
     +  LNBR(I),RNBR(I))
      END IF
      CALL MOVTAG(FROM,TO)
      END
      SUBROUTINE DBOPEN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,NAMPRO,GEL,
     +IDBSIS,IDBSIZ,IERR,KBIN,KBOUT,
     +IDEVR,IDEVW,IDEVN,IDEVT,IDEVC,
     +MAXGEL,MAXGLM,LLINO,
     +IDM,IHELPS,IHELPE,HELPF,IDEVH)
C   AUTHOR: RODGER STADEN
      CHARACTER GEL(MAXGLM)
      INTEGER RELPG(IDBSIS)
      INTEGER LNGTHG(IDBSIS),LNBR(IDBSIS),RNBR(IDBSIS)
      CHARACTER NAMPRO*(*),COPYNO*4,HELPF*(*)
      INTEGER IWORD,ACTF
      EXTERNAL ACTF
      PARAMETER (IWORD=4)
C  NOTE THIS IS THE MACHINES WORD LENGTH IE HOW MANY CHARS PER WORD
      CALL FILLI(RELPG,IDBSIS,0)
      CALL FILLI(LNGTHG,IDBSIS,0)
      CALL FILLI(LNBR,IDBSIS,0)
      CALL FILLI(RNBR,IDBSIS,0)
      NAMPRO(1:)=' '
      IERR=1
1     CONTINUE
      L = 0
      CALL GTSTR('Project name',' ',NAMPRO,L,KBOUT,KBIN,INFLAG)
      IF(L.LT.1) RETURN
      LL = L
      CALL CCASE(NAMPRO,1)
      IF(INFLAG.EQ.2) RETURN
      IF(INFLAG.EQ.1) THEN
        CALL HELP2(IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        GO TO 1
      END IF
      L = 1
      CALL GTSTR('Version','0',COPYNO,L,KBOUT,KBIN,INFLAG)
      CALL CCASE(COPYNO,1)
      IF(INFLAG.EQ.2) RETURN
      IF(INFLAG.EQ.1) THEN
        CALL HELP2(IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        GO TO 1
      END IF
      IF(L.LT.1) COPYNO(1:1) = '0'
C
C check if file is open
C
      NAMPRO(LL+1:LL+2) = '.'//COPYNO(1:1)
      IOK = ACTF(1,NAMPRO,LL,COPYNO,KBOUT)
      IF (IOK.NE.0) RETURN
      NAMPRO(LL+1:LL+3)='.AR'
      NAMPRO(LL+4:LL+4)=COPYNO(1:1)
       CALL OPENRS(IDEVN,NAMPRO,IOK,4,4)
      IF(IOK.NE.0)GO TO 100
      NAMPRO(LL+2:LL+3)='RL'
       CALL OPENRS(IDEVR,NAMPRO,IOK,4,4)
      IF(IOK.NE.0)GO TO 100
      CALL READR(IDEVR,0,IDBST,IDBSIZ,MAXGEL,IDM)
C
C Do I really need to look at this value? I could simply compare
C IDBSIS with IDBSIZ which is what really counts. Cannot remember
C why IDBST is stored!!!!!!!
C
      IF(IDBST.GT.IDBSIS) THEN
        CALL ERROM(KBOUT,
     +  'Fatal error: database size too large for program')
        GO TO 100
      END IF
      NAMPRO(LL+2:LL+3)='SQ'
C  DEFINE RECORD LENGTH IN TERMS OF NUMBER OF CHARS PER WORD (4 ON VAX)
C  AND MAXGEL SIZE 
      IREC=MAXGEL/IWORD
      IF(MOD(MAXGEL,IWORD).NE.0)IREC=IREC+1
       CALL OPENRS(IDEVW,NAMPRO,IOK,IREC,4)
      IF(IOK.NE.0)GO TO 100
      NAMPRO(LL+2:LL+3) = 'TG'
      CALL OPENRS(IDEVT,NAMPRO,IOK,5,4)
      IF(IOK.NE.0) IDEVT = -1
      NAMPRO(LL+2:LL+3) = 'CC'
C  COMMENT_LENGTH: 11 = (40 + long)/long
      CALL OPENRS(IDEVC,NAMPRO,IOK,11,4)
      IF(IOK.NE.0) IDEVC = -1
C   READ A LINE FOR LUCK
      CALL READW(IDEVW,1,GEL,MAXGEL)
      CALL READR(IDEVR,IDBSIZ,NGELS,NCONTS,IDUM1,IDUM2)
      WRITE(KBOUT,10011)NGELS,NCONTS,IDBSIZ,MAXGEL
10011 FORMAT(' Number of gel readings ',I6,' Number of contigs ',I6,/,
     +' Database size ',I6,' Maximum gel reading length=',I4)
      LLINO = 0
      IF(NGELS.LT.1)GO TO 5
      DO 3 I=1,NGELS
        CALL READR(IDEVR,I,RELPG(I),LNGTHG(I),LNBR(I),RNBR(I))
3     CONTINUE
      N=IDBSIZ-NCONTS
      MXT = 0
      DO 4 I=N,IDBSIZ-1
        CALL READR(IDEVR,I,RELPG(I),LNGTHG(I),LNBR(I),RNBR(I))
        IF(RELPG(I).GT.MXT) THEN
          MXT = RELPG(I)
          LLINO = LNBR(I)
        END IF
4     CONTINUE
5     CONTINUE
      NAMPRO(LL+2:LL+2) = COPYNO(1:1)
      IERR=0
      RETURN
100   CONTINUE
      IOK = ACTF(2,NAMPRO,LL,COPYNO,KBOUT)
      WRITE(KBOUT,9999)
9999  FORMAT(' Error encountered opening database files')
      NAMPRO(LL+2:LL+2) = COPYNO(1:1)
      END
      SUBROUTINE DBSTAR(NAMPRO,GEL,IDBSIS,IDBSIZ,KBIN,KBOUT,
     +IDEV1,IDEV2,IDEV3,IDEVT,IDEVC,
     +IERR,IHELPS,IHELPE,IDEVH,FILEH,
     +MAXGEL,MAXGLM,IDM)
      CHARACTER GEL(MAXGLM),FILEH*(*)
      CHARACTER NAMPRO*(*)
      INTEGER IWORD,ACTF
      PARAMETER (IWORD=4)
      EXTERNAL ACTF
      IERR=1
3     CONTINUE
      NAMPRO = ' '
      MN = 0
      CALL GTSTR('New project name',' ',NAMPRO,MN,KBOUT,KBIN,INFLAG)
      IF(MN.LT.1) RETURN
      LL = MIN(12,MN)
      CALL CCASE(NAMPRO,1)
      IF(INFLAG.EQ.2) RETURN
      IF(INFLAG.EQ.1) THEN
        CALL HELP2(IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
        GO TO 3
      END IF
      NAMPRO(LL+1:LL+2) = '.0'
      IOK = ACTF(1,NAMPRO,LL,'0',KBOUT)
      IF (IOK.NE.0) RETURN
      MN = 10
      MX = IDBSIS
      IDBSIZ = 50
      CALL GETINT(MN,MX,IDBSIZ,
     +'Database size',
     +IVAL,KBIN,KBOUT,
     +IHELPS,IHELPE,FILEH,IDEVH,IOK)
      IF(IOK.NE.0) GO TO 40
      IDBSIZ = IVAL
5     CONTINUE
      MN = 512
      MX = MAXGLM
      MAXIN1 = MIN(512,MAXGEL)
      MAXIN = 1024
      CALL GETINT(MN,MX,MAXIN,
     +'Maximum gel reading length',
     +IVAL,KBIN,KBOUT,
     +IHELPS,IHELPE,FILEH,IDEVH,IOK)
      IF(IOK.NE.0) GO TO 40
      MAXGEL = IVAL
      IF(MOD(IVAL,MAXIN1).NE.0) THEN
        MAXGEL = 512 + (IVAL/512)*512
        WRITE(KBOUT,*)'Maximum set to',MAXGEL
      END IF
      CALL YESNO(IDM,'Database is for DNA',
     +IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
      IF(IDM.LT.0) GO TO 40
      IF(IDM.EQ.0)IDM = 5
      IF(IDM.EQ.1)IDM = 26
      NAMPRO(LL+1:LL+4)='.RL0'
      CALL OPENRS(IDEV1,NAMPRO,IOK,4,3)
      IF(IOK.NE.0)GO TO 100
      WRITE(KBOUT,1004)
1004  FORMAT(' Writing new database files')
      J = 0
      K = 0
      N = 0
      M = 0
C
C Put maximum possible database size, actual size, max read length and type
C in record 0 of relationships (actually record 1, as writer adds 1).
C
      CALL WRITER(IDEV1,0,IDBSIS,IDBSIZ,MAXGEL,IDM)
C
C Put zeroes in al other records
C
      DO 10 I=1,IDBSIZ
        CALL WRITER(IDEV1,I,J,K,M,N)
10    CONTINUE      
      NAMPRO(LL+2:LL+3)='SQ'
      IREC=MAXGEL/IWORD
      IF(MOD(MAXGEL,IWORD).NE.0)IREC=IREC+1
      CALL OPENRS(IDEV2,NAMPRO,IOK,IREC,3)
      IF(IOK.NE.0)GO TO 100
      CALL FILLC(GEL,MAXGEL,' ')
C      CALL WRITEW(IDEV2,IDBSIZ,GEL,MAXGEL)
C
C  write only the first record into the working versions
C  and assume others will be added when required
C
      CALL WRITEW(IDEV2,1,GEL,MAXGEL)
      NAMPRO(LL+2:LL+3)='AR'
      CALL OPENRS(IDEV3,NAMPRO,IOK,4,3)
      IF(IOK.NE.0)GO TO 100
C
C  write only the first record into the names
C  and assume others will be added when required
C
      CALL WRITEN(IDEV3,1,'                ')
C  CREATE TAG FILES (TAGS AND COMMENTS)
        NAMPRO(LL+2:LL+3)='TG'
        CALL OPENRS(IDEVT,NAMPRO,IOK,5,3)
        IF(IOK.NE.0)GO TO 100
        CALL WRITTG(IDEVT,IDBSIZ,IDBSIZ,0,0,0,0)
        NAMPRO(LL+2:LL+3)='CC'
C  COMMENT_LENGTH: 11 = (40 + long)/long
        CALL OPENRS(IDEVC,NAMPRO,IOK,11,3)
        IF(IOK.NE.0)GO TO 100
        CALL WRITCC(IDEVC,1,1,0,' ')
      WRITE(KBOUT,1003)NAMPRO(1:LL),IDBSIZ
1003  FORMAT(' Database ',A,' version 0, size ',I6,
     +' successfully started')
      IERR=0
      NAMPRO(LL+2:LL+2) = '0'
      RETURN
 40   CONTINUE
      NAMPRO(LL+1:LL+2) = '.0'
      IOK = ACTF(2,NAMPRO,LL,'0',KBOUT)
      RETURN
100   CONTINUE
      CALL ERROM(KBOUT,'Error writing database files')
      NAMPRO(LL+1:LL+2) = '.0'
      IOK = ACTF(2,NAMPRO,LL,'0',KBOUT)
      END
      SUBROUTINE FIXRD(IDEVT,IDEVC,IDBSIZ,KBIN,KBOUT,
     +IHELPS,IHELPE,FILEH,IDEVH)
C FILE_NAME_LENGTH
      CHARACTER NAMFIL*18,NEWNAM*18,MTYPE*4,NEWMT*4,FILEH*(*)
      IF(IDEVRD.LT.0) THEN
        WRITE(KBOUT,*)'No raw data file!'
        RETURN
      END IF
 10   CONTINUE
C  Change raw data record
        MN = 0
        MX = IDBSIZ-1
        LNO = 0
        CALL GETINT(MN,MX,LNO,
     +  'Number of line to change',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        IF(IVAL.EQ.0) RETURN
        LNO = IVAL
        CALL READRD(IDEVT,IDEVC,LNO,LENR,LCUT,LENW,MTYPE,NAMFIL)
        WRITE(KBOUT,*)'Current line'
        WRITE(KBOUT,1001)LENR,LCUT,LENW,MTYPE,NAMFIL
1001    FORMAT(' ',3I6,' ',A,' ',A)
        MN = 1
        MX = 9999
        LX  = LENR
        CALL GETINT(MN,MX,LX,
     +  'Length raw sequence',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        LX = IVAL
        MN = 1
        MX = LX
        L  = LCUT
        CALL GETINT(MN,MX,L,
     +  'Left cutoff',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) GO TO 10
        L = IVAL
        MN = 1
        MX = LX
        M  = LENW
        CALL GETINT(MN,MX,M,
     +  'Length of original working sequence',
     +  IVAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,FILEH,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        M = IVAL
 20     CONTINUE
        LNAM = 4
        CALL GTSTR('Machine type',
     +  MTYPE,NEWMT,LNAM,KBOUT,KBIN,INFLAG)
        IF(INFLAG.EQ.2) RETURN
        IF(INFLAG.EQ.1) THEN
          CALL HELP2(IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
          GO TO 20
        END IF
        IF(INFLAG.EQ.3) NEWMT = MTYPE
 30     CONTINUE
C FILE_NAME_LENGTH
        LNAM = 18
        CALL GTSTR('Name for raw data file',
     +  NAMFIL,NEWNAM,LNAM,KBOUT,KBIN,INFLAG)
        IF(INFLAG.EQ.2) RETURN
        IF(INFLAG.EQ.1) THEN
          CALL HELP2(IHELPS,IHELPE,FILEH,IDEVH,KBIN,KBOUT)
          GO TO 30
        END IF
        IF(INFLAG.EQ.3) NEWNAM = NAMFIL
        WRITE(KBOUT,1001)LX,L,M,NEWMT,NEWNAM
        CALL WRITRD(IDEVT,IDEVC,LNO,LX,L,M,NEWMT,NEWNAM)
        WRITE(KBOUT,*)'New record written to disk'
        GO TO 10
        END
      SUBROUTINE READRD(IDEVT,IDEVC,NGEL,LENR,LCUT,LENW,MTYPE,NAMFIL)
      CHARACTER MTYPE*(*),NAMFIL*(*)
C  COMMENT_LENGTH
      CHARACTER NOTE*40
      IF(IDEVT.GT.0)THEN
        CALL READTG(IDEVT,NGEL,LPOS,LLEN,LCOM,LTYPE,NEXT)
        CALL READCC(IDEVC,LCOM,ICNT,NEXT,NOTE)
        READ(NOTE,1001,ERR=100)LENR,LCUT,LENW,MTYPE,NAMFIL
 1001   FORMAT(3I6,A,A)
      ENDIF
      RETURN
 100  CONTINUE
      LENR = 0
      LCUT = 0
      LENW = 0
      MTYPE = ' '
      NAMFIL = ' '
      END
      SUBROUTINE WRITRD(IDEVT,IDEVC,NGEL,LENR,LCUT,LENW,MTYPE,NAMFIL)
      CHARACTER MTYPE*(*),NAMFIL*(*)
      INTEGER FREECC
C  COMMENT_LENGTH
      CHARACTER NOTE*40
      IF(IDEVT.GT.0)THEN
        CALL READTG(IDEVT,NGEL,LPOS,LLEN,LCOM,LTYPE,NEXT)
        IF(LCOM.EQ.0)THEN
          LCOM = FREECC(IDEVC)
        ENDIF
        WRITE(NOTE,1001,ERR=100)LENR,LCUT,LENW,MTYPE,NAMFIL
 1001   FORMAT(3I6,A,A)
        NEXT = 0
        CALL WRITCC(IDEVC,LCOM,ICNT,NEXT,NOTE)
      ENDIF
      RETURN
 100  CONTINUE
      END
      SUBROUTINE READTG(IDEVT,I,LPOS,LLEN,LCOM,LTYPE,NEXT)
      INTEGER SWAPBO
      EXTERNAL SWAPBO
      IF(IDEVT.GT.0) THEN
        READ(IDEVT,REC=I)LPOS,LLEN,LCOM,LTYPE,NEXT
        LPOS = SWAPBO(LPOS)
        LLEN = SWAPBO(LLEN)
        LCOM = SWAPBO(LCOM)
        NEXT = SWAPBO(NEXT)
      ENDIF
      END
      SUBROUTINE WRITTG(IDEVT,I,LPOS,LLEN,LCOM,LTYPE,NEXT)
      INTEGER SWAPBO
      EXTERNAL SWAPBO
      IF (IDEVT.GT.0) THEN
        WRITE(IDEVT,REC=I)SWAPBO(LPOS),SWAPBO(LLEN),
     +SWAPBO(LCOM),LTYPE,SWAPBO(NEXT)
      ENDIF
      END
      SUBROUTINE READCC(IDEVC,I,ICNT,NEXT,NOTE)
C  COMMENT_LENGTH
      CHARACTER NOTE*40
C  COMMENT_LENGTH - 4
      CHARACTER DUMM*36
      INTEGER SWAPBO
      EXTERNAL SWAPBO
      IF(IDEVC.GT.0)THEN
        READ(IDEVC,REC=1)NEXT,ICNT,DUMM
        NEXT = SWAPBO(NEXT)
        ICNT = SWAPBO(ICNT)
        IF(I.EQ.0.OR.I.GT.ICNT)THEN
          NEXT = 0
          NOTE = ' '
        ELSE
          READ(IDEVC,REC=I)NEXT,NOTE
          NEXT = SWAPBO(NEXT)
        ENDIF
      ENDIF
      END
      SUBROUTINE WRITCC(IDEVC,I,ICNT,NEXT,NOTE)
C  COMMENT_LENGTH
      CHARACTER NOTE*40
C  COMMENT_LENGTH - 4
      CHARACTER DUMM*36
      INTEGER SWAPBO
      EXTERNAL SWAPBO
      IF(IDEVC.GT.0)THEN
        IF(I.EQ.1) THEN
          WRITE(IDEVC,REC=1)SWAPBO(NEXT),SWAPBO(ICNT),DUMM
        ELSE
          READ(IDEVC,REC=1)IDUM,ICNT,DUMM
          ICNT = SWAPBO(ICNT)
          IF(I.LE.ICNT) THEN
             WRITE(IDEVC,REC=I)SWAPBO(NEXT),NOTE
          ENDIF
        ENDIF
      ENDIF
      END
      SUBROUTINE PADCON(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +GEL,LINCON,POSN,NC,IDBSIZ,IDEVR,IDEVW,MAXGEL,KBOUT)
C   AUTHOR: RODGER STADEN
      INTEGER RELPG(IDBSIZ),POSN,X
      INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
      CHARACTER GEL(MAXGEL)
      CHARACTER PAD
      SAVE PAD
      DATA PAD/'*'/
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
C   NOT IN REGION
      LLINO=RNBR(LLINO)
      GO TO 30
40    CONTINUE
C   NOW GET THIS GEL FROM DISK
      CALL READW(IDEVW,LLINO,GEL,MAXGEL)
C   CALC POSN IN THIS GEL TO EDIT
      X=POSN-RELPG(LLINO)+1
      K=X
C   MOVE THE DATA RIGHT
      M=ABS(LNGTHG(LLINO))
      LNGTHG(LLINO)=LNGTHG(LLINO)+SIGN(NC,LNGTHG(LLINO))
C   CHECK FOR OVER END OF ARRAY
      N=ABS(LNGTHG(LLINO))
      IF(N.GT.MAXGEL)THEN
        WRITE(KBOUT,1000)LLINO
1000    FORMAT(
     +' Data pushed off end of gel',I4,' during padding')
        M=M-(N-MAXGEL)
        N=MAXGEL
        LNGTHG(LLINO)=SIGN(MAXGEL,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
      DO 60 I=K,MIN(MAXGEL,K+NC-1)
        GEL(I)=PAD
60    CONTINUE
C   WRITE BACK TO DISK
      CALL WRITEW(IDEVW,LLINO,GEL,MAXGEL)
C   WRITE NEW LINE
      CALL WRITER(IDEVR,LLINO,RELPG(LLINO),LNGTHG(LLINO),
     +LNBR(LLINO),RNBR(LLINO))
C   NOW UPDATE TAG FILES ACCORDINGLY
      CALL PADTAG(LLINO,K,NC,LNGTHG(LLINO))
65    CONTINUE
C   NOW GET NEXT GEL
      LLINO=RNBR(LLINO)
C   LAST GEL?
      IF(LLINO.EQ.0)GO TO 70
C   DOES IT HAVE DATA IN REGION?
C   IE DO RELPG  AND RELPG+LNGTHG-1 LIE EITHER SIDE OF POSN?
      IF(RELPG(LLINO).GT.POSN)GO TO 70
      X=RELPG(LLINO)+ABS(LNGTHG(LLINO))-1
      IF(X.LT.POSN)GO TO 65
C  WITHIN
      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
C   WRITE NEW LINE
      CALL WRITER(IDEVR,LLINO,RELPG(LLINO),LNGTHG(LLINO),
     +LNBR(LLINO),RNBR(LLINO))
      GO TO 76
90    CONTINUE
C   NEED TO INCREMENT CONTIG LINE
      RELPG(LINCON)=RELPG(LINCON)+NC
      CALL WRITER(IDEVR,LINCON,RELPG(LINCON),LNGTHG(LINCON),
     +LNBR(LINCON),RNBR(LINCON))
      END
      SUBROUTINE AUTOJ(RELPG,LNGTHG,LNBR,RNBR,MAXDB,IDBSIZ,
     +NGELS,NCONTS,MAXGEL,
     +TEMP3,WORDP,WORDN,LPOWRC,POSNS,GELN,
     +SEQ1,MAXSEQ,SEQ2,SEQ3,SEQ4,SEQ5,SEQC2,SEQG2,MATCH,
     +MAXGLM,MAXGL2,CHRSIZ,ECHRSZ,LENGTH,
     +SAV1,SAV2,SAV3,MAXSAV,CENDS,NENDS,MAXCON,CONST,
     +KBIN,KBOUT,IDEV1,IDEV2,IDEV3,IDEV4,IDEV7,IDEV8,IDEV,
     +IHELPS,IHELPE,HELPF,IDEVH,NAMARC,NAMPRO,FILE,
     +PERCD,IOPEN,IDM,SEQG3,SEQC3,IOK,IDEVC,IDEVT)
      INTEGER CHRSIZ,ECHRSZ
      INTEGER RELPG(MAXDB)
      INTEGER LNGTHG(MAXDB),LNBR(MAXDB),RNBR(MAXDB)
      INTEGER JOINT(2),ITOTPC(2),ITOTPG(2),IDIM22(2),IDOUT(2)
      INTEGER LLINO(2),ITYPE(2),IFAIL
      INTEGER ILEFTS(2),ILC(2),IPOSC(2),IPOSG(2),ISENSE(2)
      INTEGER WINDOW
      INTEGER TEMP3(ECHRSZ,MAXGL2),CONST(LENGTH)
      INTEGER POSNS(MAXSEQ),WORDP(LPOWRC),WORDN(LPOWRC),GELN(MAXGLM)
      INTEGER CENDS(MAXCON),NENDS(MAXCON)
      CHARACTER SEQ3(MAXGLM),SEQC2(MAXGLM,2),SEQG2(MAXGLM,2)
      CHARACTER SEQ1(MAXSEQ),SEQ2(MAXGLM),MATCH(MAXGLM),SEQ4(MAXGLM)
      INTEGER SAV1(MAXSAV),SAV2(MAXSAV),SAV3(MAXSAV)
      CHARACTER NAMARC*(*),NAMPRO*(*),FILE*(*)
      CHARACTER SEQ5(MAXGLM),HELPF*(*),SEQG3(MAXGLM),SEQC3(MAXGLM)
      CALL DBCHEK(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +  TEMP3,IERR,KBOUT)
      IF(IERR.GT.1) RETURN
      IFAIL = 0
      IF(NGELS.LT.1) RETURN
      MN = LENGTH*2
      MX = MAXGLM + 1
      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
      MINSLI = 3
      MN = 0
      MX = 50
      MAXPG = 8
      CALL GETINT(MN,MX,MAXPG,
     +'Maximum pads per sequence',
     +IVAL,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MAXPG = IVAL
      MAXPC = IVAL
        RMN = 0.
        RMX = 100.
        PERMAX = 75.
        CALL GETRL(RMN,RMX,PERMAX,
     +  'Maximum percent mismatch after alignment',
     +  VAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) RETURN
        PERMAX = VAL
      MN = MINMAT
      MX = MAXGEL
      WINDOW = 100
      CALL GETINT(MN,MX,WINDOW,
     +'Probe length',
     +IVAL,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      WINDOW = IVAL
       IOK = 1
       I = 0
       CALL YESNO(I,'Use clipped data',
     +  IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
       IF(I.LT.0) RETURN
       IWING = 0
       IF(I.EQ.0) THEN
         MN = 1
         MX = MAXGEL
         IWING = 100
         CALL GETINT(MN,MX,IWING,
     +   'Window size for good data scan',
     +   IVAL,KBIN,KBOUT,
     +   IHELPS,IHELPE,HELPF,IDEVH,IOK)
         IF(IOK.NE.0) RETURN
         IWING = IVAL
         MN = 1
         MX = MIN(100,IWING)
         NBAD = MIN(IWING,5)
         CALL GETINT(MN,MX,NBAD,
     +   'Maximum number of dashes in scan window',
     +   IVAL,KBIN,KBOUT,
     +   IHELPS,IHELPE,HELPF,IDEVH,IOK)
         IF(IOK.NE.0) RETURN
         NBAD = IVAL
       END IF
      MAXOVR=MAXGEL-3*MAX(MAXPC,MAXPG)
      IDIM2=MAXGEL
C
C Note I am doing something horrible here to save space:
C temp3 is used for cends, nends and as temp3. I can do this
C because i call fndcon to reinstate cends ,nends after each
C use of temp3 for the consensus calc. However iladd and iradd
C need the same amount of storage as cends and nends so i use
C the arrays cends and nends for them. iladd and iradd are not
C updated after use of temp3. The switch in array use is made 
C by the following subroutine call
C
C replaced following line 25-9-92
C     +SAV1,SAV2,SAV3,MAXSAV,TEMP3,TEMP3(MAXCON+1,1),MAXCON,
C
      CALL AUTOJN(SEQ1,MAXSEQ,SEQ2,IDIM2,ILEFTS,ILC,IPOSC,
     +IPOSG,ISENSE,LLINO,IMATC,IFCOMP,MINMAT,POSNS,WORDP,WORDN,
     +CONST,LENGTH,LPOWRC,IDEV,MATCH,MAXGEL,MAXGLM,SEQ5,GELN,
     +SAV1,SAV2,SAV3,MAXSAV,TEMP3,TEMP3(1,1+MAXCON/2),MAXCON,
     +SEQG2,SEQC2,SEQ4,IDOUT,IDIM22,ITOTPG,ITOTPC,JOINT,IFAIL,
     +ITYPE,MAXPC,MAXPG,PERMAX,MINSLI,SEQG3,SEQC3,KFAIL,
     +WINDOW,CENDS,NENDS,RELPG,LNBR,IDBSIZ,NGELS,NCONTS,
     +LNGTHG,RNBR,IDEV1,IDEV2,IDEV3,IDEVT,IDEVC,PERCD,IWING,NBAD,
     +ECHRSZ,SEQ5,TEMP3,MAXGL2,IDM,NAMPRO,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH)
      END
C
      SUBROUTINE AUTOJN(SEQ1,MAXSEQ,GEL,IDIMGI,ILEFTS,
     +ILC,IPOSC,
     +IPOSG,ISENSE,LLINO,IMATC,IFCOMP,MINMAT,POSNS,WORDP,WORDN,
     +CONST,LENGTH,LPOWRC,IDEV,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,
     +WINDOW,ILADD,IRADD,RELPG,LNBR,IDBSIZ,NGELS,NCONTS,
     +LNGTHG,RNBR,IDEV1,IDEV2,IDEV3,IDEVT,IDEVC,PERCD,IWING,NBAD,
     +ECHRSZ,SEQ5,TEMP3,MAXGL2,IDM,NAMPRO,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH)
C   AUTHOR: RODGER STADEN
      INTEGER ECHRSZ
      INTEGER ILEFTS(2),ILC(2),IPOSC(2),IPOSG(2),ISENSE(2),LLINO(2)
      INTEGER POSNS(MAXSEQ),GELN(MAXGLM),WORDP(LPOWRC),SAVPS(MAXSAV)
      INTEGER SAVPG(MAXSAV),SAVL(MAXSAV)
      INTEGER WORDN(LPOWRC)
      CHARACTER GELCOP(MAXGLM),MATCH(MAXGLM),NAMPRO*(*),HELPF*(*)
      INTEGER CENDS(MAXCON),NENDS(MAXCON),ILADD(MAXCON),IRADD(MAXCON)
      INTEGER CONST(LENGTH)
      CHARACTER SEQ1(MAXSEQ),GEL(MAXGLM),SEQ5(MAXGLM)
      CHARACTER SEQG2(MAXGLM,2),SEQC2(MAXGLM,2),SEQ4(MAXGLM)
      INTEGER IDOUT(2),IDIM22(2),ITOTPG(2),ITOTPC(2),JOINT(2)
      INTEGER IFAIL,ITYPE(2)
      PARAMETER (MAXC = 100)
      CHARACTER SEQG3(MAXGLM),SEQC3(MAXGLM)
      INTEGER JLEFTS(MAXC),JLC(MAXC),JPOSC(MAXC),JPOSG(MAXC),MCON(MAXC)
      INTEGER JSENSE(MAXC),JLLINO(MAXC),WINDOW,CSTART
      INTEGER RELPG(IDBSIZ),LNBR(IDBSIZ),LNGTHG(IDBSIZ),RNBR(IDBSIZ)
      INTEGER TEMP3(ECHRSZ,MAXGL2)
      INTEGER CLINNO,CHAINL,XVERSN
      EXTERNAL CLINNO,CHAINL,XVERSN
      IEXT = 0
      IF (IWING.NE.0) IEXT = 1
      IFAIL = 1
      KFAIL = 0
C
C calc the consensus and add the unused data if required
C save the lengths of the unused data in iladd, iradd
C
      CALL FILLI(ILADD,NCONTS,0)
      CALL FILLI(IRADD,NCONTS,0)
      IDIM = 0
      JOB = 0
      CALL JCONS(RELPG,LNGTHG,LNBR,RNBR,NAMPRO,NGELS,NCONTS,
     +SEQ1,MAXSEQ,GEL,IDBSIZ,IDIM,JOB,KDUMM,KDUMM,KDUMM,KDUMM,
     +TEMP3,
     +ECHRSZ,MAXGL2,KBOUT,IDEV2,IFAIL,MAXGEL,IDM,PERCD,SEQ5,
     +ILADD,IRADD,MAXCON,KDUMM,IWING,NBAD)
      IDCEND=MAXCON
      CALL FNDCON(SEQ1,IDIM,CENDS,NENDS,IDCEND,MAXCON,KBOUT)
C      WRITE(*,*)'IDIM',IDIM
C      WRITE(*,*)(CENDS(K),NENDS(K),K=1,IDCEND)
C
C find possible missed joins
C we have consensus in seq1 in order first contig,second contig etc
C compare the ends in reverse order, simultaneously shortening the consensus
C the total consensus length is denoted by idimin
C but we compare the last contig to the rest so denote the length
C of the rest by idim
C
      NFOUND = 0
      NMADE = 0
C
C init hashing constants
C
      CALL INITE(CONST,CSTART,LENGTH)
C
C idim is the length up to the end of the last but 1 consensus
C (we get from the start of the last contig)
C jcon is the last contig (ie the one we are currently comparing)
C
      JCON = IDCEND + 1
C
C come here for the next contig
C
 10   CONTINUE
C
C
      IDIMIN = IDIM
C        WRITE(*,*)'IDIM,IDIMIN',IDIM,IDIMIN
      JCON = JCON - 1
C
C come here if weve just made a join
C
 20   CONTINUE
C
C
C      WRITE(*,*)'*********COMPARING CONTIG',JCON
      IF (JCON.GT.1) THEN
C        WRITE(*,*)'IDCEND,JCON'
C        WRITE(*,*)IDCEND,JCON
C          WRITE(*,1222)
C     + (K,NENDS(K),CENDS(K),ILADD(K),IRADD(K),K=1,JCON)
C 1222     FORMAT(5I6)
C          WRITE(*,*)(ILADD(K),IRADD(K),K=1,JCON)
        IDIM = CENDS(JCON) - 1
C        WRITE(*,*)'IDIM,IDIMIN',IDIM,IDIMIN
        CALL ENCOF(SEQ1,IDIM,CONST,CSTART,LENGTH,POSNS)
        CALL ENCONN(POSNS,IDIM,WORDP,WORDN,LPOWRC,LENGTH,1)
C
C point to probes at the ends of the current contig
C
        JS = CENDS(JCON) + 20
        JE = CENDS(JCON+1) - 1
        IEND = 1
        IDIMG = MIN(WINDOW,JE-JS+1)
C
C check for case where contig is shorter than probe (window)
C in which case only compare the left hand end
C
        IF(JE-JS+1.LE.WINDOW) IEND = 2
C
C come here for left end of contig
C
 30     CONTINUE
C
C
C        WRITE(*,*)'JCON,JS,JE,IDIMG'
C        WRITE(*,*)JCON,JS,JE,IDIMG
        IMATC = 0
        IF(IEND.EQ.1) THEN
          CALL SQCOPY(SEQ1(JE-IDIMG+1),GEL,IDIMG)
        ELSE
          CALL SQCOPY(SEQ1(JS),GEL,IDIMG)
        END IF
        CALL SQCOPY(GEL,GELCOP,IDIMG)
        ISTRAN=1
C
C come here for strand 2
C
 40     CONTINUE
C
C
        CALL ENCOF(GEL,IDIMG,CONST,CSTART,LENGTH,GELN)
        IDSAV=MAXSAV
        CALL CFGEL(GELN,IDIMG,POSNS,IDIM,WORDP,WORDN,LENGTH,LPOWRC,
     +  SAVPG,SAVPS,SAVL,
     +  IDSAV,SEQ1,GEL,MINMAT,IFCOMP,IDEV)
        IF(IFCOMP.NE.0) THEN
           CALL ERROM(KBOUT,'Error in CFGEL')
           RETURN
        END IF
        IF(IDSAV.NE.0)THEN
          CALL ADISM5(IDIM,IDIMG,SAVPS,SAVPG,IDSAV,CENDS,NENDS,
     +    IDCEND,MAXCON,JLEFTS,JLC,JPOSC,JPOSG,JSENSE,JLLINO,
     +    IMATC,ISTRAN,MAXC,KBOUT,MCON)
        END IF
        ISTRAN=ISTRAN+1
C
C have we done both strands for this probe ?
C
        IF(ISTRAN.EQ.2) THEN
          CALL SQCOPY(GELCOP,GEL,IDIMG)
          CALL SQREV(GEL,IDIMG)
          CALL SQCOM(GEL,IDIMG)
          GO TO 40
        END IF
        CALL SQCOPY(GELCOP,GEL,IDIMG)
        KSENSE = 0
C        WRITE(KBOUT,*)'Total matches found',IMATC
C        CALL FMTDB(SEQ1,IDIMIN,1,IDIMIN,60,KBOUT)
        IF(IMATC.NE.0) THEN
          JMATC = 0
C
C loop for all matches on both strands
C
          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
            CALL ALINEJ(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,IDEV,
     +      SEQ4,MAXGEL,PERMS,
     +      NENDS(JCON),IEND,JLLINO(I),JSENSE(I),ILADD,IRADD,MAXCON,
     +      MCON(I),
     +      JCON,RELPG,LNBR,IDBSIZ,NCONTS,NFOUND,IENDCT,IENDGT)
            IF (JFAIL.NE.0) GO TO 100
C
C if this is the x version and the results are being shown on the  screen
C we can offer the join editor and make the join
C
            IF ((XVERSN().NE.0).AND.(IDEV.EQ.KBOUT)) THEN
C
C another horrible thing here: sending posns for use by dbchek after
C a join is made (only used then)
C
              CALL USJED(
     +        SEQ1,MAXSEQ,IDIMIN,IDIM,GEL,KBIN,KBOUT,MAXGEL,MAXGLM,
     +        CENDS,NENDS,MAXCON,IFAIL,MCON(I),JCON,NAMPRO,
     +        JSENSE(I), JLLINO(I),
     +        ILADD,IRADD,RELPG,LNBR,IDBSIZ,NGELS,
     +        NCONTS,
     +        LNGTHG,RNBR,IDEV1,IDEV2,IDEV3,IDEVT,IDEVC,
     +        PERCD,IWING,NBAD,
     +        IENDGT,IENDCT,SEQ4,IDCEND,IEXT,
     +        ECHRSZ,SEQ5,TEMP3,MAXGL2,IDM,
     +        IHELPS,IHELPE,HELPF,IDEVH,POSNS,NMADE,IOK)
              IF (IFAIL.NE.0) GO TO 200
              IF (NCONTS.EQ.1) GO TO 200
              IF (IOK.EQ.2) GO TO 200
C
C if join has been made, assume everything is tidy and do this contig again
C
              IF (IOK.EQ.0) GO TO 20
            END IF
100       CONTINUE
        END IF
        IEND = IEND + 1
C
C have we done both ends of this contig ?
C
        IF(IEND.EQ.2) GO TO 30
C
C do the next contig
C
        GO TO 10
      END IF
C
C jump here if only one contig left ! or user wants to escape
C
 200  CONTINUE
      WRITE(KBOUT,*)'Number of potential joins found',NFOUND
      WRITE(KBOUT,*)'Number of joins made',NMADE
      END
      SUBROUTINE USJED(
     +SEQ1,MAXSEQ,IDIMIN,IDIM,GEL,KBIN,KBOUT,MAXGEL,MAXGLM,
     +CENDS,NENDS,MAXCON,IFAIL,MCON,JCON,NAMPRO,JSENSE,JLLINO,
     +ILADD,IRADD,RELPG,LNBR,IDBSIZ,NGELS,NCONTS,
     +LNGTHG,RNBR,IDEV1,IDEV2,IDEV3,IDEVT,IDEVC,PERCD,IWING,NBAD,
     +IENDGT,IENDCT,SEQ2,IDCEND,IEXT,
     +ECHRSZ,SEQ5,TEMP3,MAXGL2,IDM,IHELPS,IHELPE,HELPF,IDEVH,
     +TEMP1,NMADE,IOK)
C   AUTHOR: RODGER STADEN
      INTEGER ECHRSZ
      INTEGER CENDS(MAXCON),NENDS(MAXCON),ILADD(MAXCON),IRADD(MAXCON)
      CHARACTER SEQ1(MAXSEQ),GEL(MAXGLM),SEQ5(MAXGLM),SEQ2(MAXGEL)
      INTEGER JSENSE,JLLINO,MCON,TEMP1(IDBSIZ)
      INTEGER RELPG(IDBSIZ),LNBR(IDBSIZ),LNGTHG(IDBSIZ),RNBR(IDBSIZ)
      INTEGER TEMP3(ECHRSZ,MAXGL2)
      INTEGER CLINNO,CHAINL
      CHARACTER HELPF*(*),NAMPRO*(*)
      EXTERNAL CLINNO,CHAINL
C      WRITE(*,*)'CURRENT MAX CONSENSUS LENGTH',MAXSEQ
C      WRITE(*,*)'CURRENT CONSENSUS LENGTH',IDIM
C      WRITE(*,*)'MAXGEL,MAXGLM,MAXCON',MAXGEL,MAXGLM,MAXCON
C      WRITE(*,*)'NGELS,NCONTS',NGELS,NCONTS
C
C routine to offer use of join editor and if join is made tidy up
C
      IFAIL = 0
      IOK = 2
      IJOIN = 0
      CALL YESNO(IJOIN,'Use the editor',
     +     IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(IJOIN.LT.0) RETURN
      IOK = 1
      IF (IJOIN.EQ.0) THEN
C
C weve called the editor
C
C
C the contig names are nends(jcon) and jllino(i)
C if jsense is -1 the contig to complement is nends(jcon)
C the position of the overlap is iendct in jllino(i) and iendgt in nends(jcon)
C we are going to need to know the endpoints of the consensuses to delete
C the element number in nends of one contig is mcon(i) and the other is jcon
C cends(i) stores the position relative to the consensus of the left end 
C of contig i
C
C        WRITE(*,*)'NENDS(JCON)',NENDS(JCON)
C        WRITE(*,*)'IDBSIZ,NCONTS',IDBSIZ,NCONTS
        IF (JSENSE.EQ.-1) THEN
          LINCON = CLINNO(LNBR,IDBSIZ,NCONTS,NENDS(JCON))
          IF (LINCON.EQ.0) THEN
C
C major cockup here: weve lost the contig number
C
            CALL ERROM(KBOUT,
     +      'Error: contig line not found for complementing')
            IFAIL = 1
            RETURN
          END IF
          CALL CMPLMT(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +    LINCON,NENDS(JCON),GEL,IDBSIZ,KBOUT,IDEV1,IDEV2,MAXGEL)
          NENDS(JCON) = LNBR(LINCON)
        END IF
C
C note the number of contigs
C
        NCIN = NCONTS
C        WRITE(*,*)'JCON,NENDS(JCON)',JCON,NENDS(JCON)
        LNCONL = CLINNO(LNBR,IDBSIZ,NCONTS,NENDS(JCON))
        IF (LNCONL.EQ.0) THEN
C
C major cockup here: weve lost the contig number
C
          CALL ERROM(KBOUT,
     +    'Error: contig line not found for left contig')
          IFAIL = 1
          RETURN
        END IF
C        WRITE(*,*)'I,MCON,NENDS(MCON)',I,MCON,NENDS(MCON)
        LNCONR = CLINNO(LNBR,IDBSIZ,NCONTS,NENDS(MCON))
        IF (LNCONR.EQ.0) THEN
C
C major cockup here: weve lost the contig number
C
          CALL ERROM(KBOUT,
     +    'Error: contig line not found for right contig')
          IFAIL = 1
          RETURN
        END IF
C        WRITE(*,*)IDBSIZ,LNCONL,NENDS(JCON),LNCONR,NENDS(MCON)
C        WRITE(*,*)IENDGT,IENDCT,PERCD,NGELS,NCONTS
C
C call the editor
C
        CALL JXEDIT(IDEV1,IDEV2,IDEV3,IDEVT,IDEVC,
     +  RELPG,LNGTHG,LNBR,RNBR,MAXGEL,
     +  IDBSIZ,LNCONR,NENDS(MCON),LNCONL,NENDS(JCON),
     +  0,IENDCT,0,IENDGT,PERCD,NGELS,NCONTS,IDM,IEXT,JOK)
C
C jok 0 = nothing done
C     1 = left contig saved
C     2 = right contig saved
C     3 = both contigs saved
C     7 = join made
C we could use these values but we dont: we only count contigs.
C if a contig is saved its consensus may be different. For now dont worry!!!!
C
C
C note we may not have joined but may have either
C complemented a contig or edited one! We shall ignore the edited
C contig, but must uncomplement the contig. See below.
C Remove the 2 consensus sequences
C Add the new one to the right end
C Update nends, cends
C Update iladd iradd, and add the new data to the end of the list
C to update iladd, iradd move all data left one element
C
        IF (NCIN.GT.NCONTS) THEN
C
C weve made a join
C
          NMADE = NMADE + 1
C
C check for consistency
C
          CALL DBCHEK(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +    TEMP1,IFAIL,KBOUT)
          IF (IFAIL.NE.0) RETURN
C
C sometimes there may only be one contig now!
C
          IF (NCONTS.EQ.1) RETURN
C
C get contig left gel number
C
          LLINOC = CHAINL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +    IDBSIZ,NENDS(JCON))
          IF (LLINOC.EQ.0) THEN
            CALL ERROM(KBOUT,'Gel number not in a contig')
            IFAIL = 1
            RETURN
          END IF
C
C get contig line number
C
          LINCON = CLINNO(LNBR,IDBSIZ,NCONTS,LLINOC)
          IF (LINCON.EQ.0) THEN
            CALL ERROM(KBOUT,'Error: contig line not found')
            IFAIL = 1
            RETURN
          END IF
C          WRITE(*,*)'DELETE CONSENSUS FROM',CENDS(MCON)
C          WRITE(*,*)'TO',CENDS(MCON+1)
C          WRITE(*,*)'SHORTEN THE CONSENSUS BY'
C          WRITE(*,*)CENDS(MCON+1)-CENDS(MCON)
C          WRITE(*,*)CENDS(JCON+1)-CENDS(JCON)
C
C shift the consensus to delete the internal consensus then
C reduce idim,idimin accordingly (for both contigs). Finally
C move the extension sizes into the appropriate elements.
C
          CALL SHFTLA(SEQ1,MAXSEQ,CENDS(MCON+1),CENDS(MCON),
     +    IDIMIN)
          IDIM = IDIM - (CENDS(JCON+1)-CENDS(JCON))
          IDIMIN = IDIMIN - (CENDS(JCON+1)-CENDS(JCON))
          IDIM = IDIM - (CENDS(MCON+1)-CENDS(MCON))
          IDIMIN = IDIMIN - (CENDS(MCON+1)-CENDS(MCON))
          DO 50 J=MCON,NCONTS-1
            ILADD(J) = ILADD(J+1)
            IRADD(J) = IRADD(J+1)
 50       CONTINUE
C
C make a consensus for the joined contig, putting it at the end
C
          JOB = 1
          JCON = JCON - 1
          CALL JCONS(RELPG,LNGTHG,LNBR,RNBR,NAMPRO,NGELS,NCONTS,
     +    SEQ1,MAXSEQ,SEQ2,IDBSIZ,IDIMIN,JOB,LLINOC,LINCON,1,
     +    RELPG(LINCON),TEMP3,
     +    ECHRSZ,MAXGL2,KBOUT,IDEV2,IFAIL,MAXGEL,IDM,PERCD,SEQ5,
     +    ILADD,IRADD,MAXCON,JCON,IWING,NBAD)
          IF (IFAIL.NE.0) RETURN
C
C now restore the contig end positions because jcons has overwritten them
C (they have changed anyway)
C
          CALL FNDCON(SEQ1,IDIMIN,CENDS,NENDS,IDCEND,MAXCON,KBOUT)
          IOK = 0
C
C   end of join made
C
        ELSE
C
C   if we get here we have called the editor but not made a join
C   so we might need to tidy up
C
          IF (JSENSE.EQ.-1) THEN
            LINCON = CLINNO(LNBR,IDBSIZ,NCONTS,NENDS(JCON))
            IF (LINCON.EQ.0) THEN
C
C major cockup here: weve lost the contig number
C
              CALL ERROM(KBOUT,
     +        'Error: contig line not found for complementing')
              IFAIL = 1
              RETURN
            END IF
            CALL CMPLMT(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +      LINCON,NENDS(JCON),GEL,IDBSIZ,KBOUT,IDEV1,IDEV2,
     +      MAXGEL)
            NENDS(JCON) = LNBR(LINCON)
          END IF
        END IF
      END IF
      END
      SUBROUTINE ALINEJ(SEQ1,SEQ2,SEQG2,SEQC2,ISAV1,ISAV2,ISAV3,
     +IDSAV,IDC,IDIM2,IDOUT,IC1,IG1,MINSLI,JOINT,
     +ITOTPC,ITOTPG,IFAIL,ITYPE,MAXPC,MAXPG,PERMAX,KBOUT,IDEV,
     +SEQ3,MAXGEL,
     +PERCM,JCONN,IEND,NCON,JSENSE,ILADD,IRADD,MAXCON,MCON,JCON,
     +RELPG,LNBR,IDBSIZ,NCONTS,NFOUND,IENDCT,IENDGT)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ1(IDC),SEQ2(IDIM2),SEQG2(IDOUT),SEQC2(IDOUT)
      CHARACTER SEQ3(MAXGEL)
      INTEGER ISAV1(IDSAV),ISAV2(IDSAV),ISAV3(IDSAV)
      INTEGER ILADD(MAXCON),IRADD(MAXCON)
      INTEGER RELPG(IDBSIZ),LNBR(IDBSIZ),WINDOW
      MINSLT=MINSLI
C   SAVE SEQ2
      CALL SQCOPY(SEQ2,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
C
C save idim2 as window
C
      WINDOW = IDIM2
      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
      CALL JALIGN(SEQC2,SEQG2,SEQ3,MAXGEL,IDOUT,IDIM2,JOINT,
     +ITYPE,PERCM,KBOUT,IDEV,IFAIL,PERMAX,JCONN,IEND,NCON,JSENSE,
     +ILADD,IRADD,MAXCON,MCON,JCON,RELPG,LNBR,IDBSIZ,NCONTS,WINDOW,
     +NFOUND,IENDCT,IENDGT)
      IF (ITOTPC.GT.MAXPC) IFAIL = 1
      IF (ITOTPG.GT.MAXPG) IFAIL = 1
      IF (PERCM.GT.PERMAX) IFAIL = 1
      END
C
C   COUNTS MISMATCHES AND DISPLAYS OVERLAP.
      SUBROUTINE JALIGN(SEQC2,SEQG2,SEQ3,MAXGEL,IDOUT,IDIM2,
     +JOINT,ITYPE,X,KBOUT,IDEV,IFAIL,PERMAX,JCONN,IEND,NCON,JSENSE,
     +ILADD,IRADD,MAXCON,MCON,JCON,RELPG,LNBR,IDBSIZ,NCONTS,WINDOW,
     +NFOUND,IENDCT,IENDGT)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQC2(MAXGEL),SEQG2(MAXGEL),SEQ3(MAXGEL)
      CHARACTER PAD,DASH,STRAND,NAME1*6,NAME2*6
      INTEGER ILADD(MAXCON),IRADD(MAXCON),RELPG(IDBSIZ),LNBR(IDBSIZ)
      INTEGER CLINNO,WINDOW
      EXTERNAL CLINNO
      SAVE PAD,DASH
      DATA PAD,DASH/',','-'/
C
C  where are the overlaps?
C
C  if ITYPE is 1 the overlap starts within the reading at JOINT
C  else it starts at the left end of the reading at JOINT in the contig
C
C
      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
C   LENGTH OF OVERLAP?
      LG=IDIM2-IENDG+1
      LO=MIN(IDOUT,LG)
C   SAVE RAW DATA
      CALL SQCOPY(SEQG2,SEQ3,IDIM2)
      X=REAL(LO)
      Y=X
      K=IENDG+LO-1
C   POINT TO CONSENSUS
      J=0
C   CHECK FOR OVERFLOW
      IF(K.GT.MAXGEL)THEN
        CALL ERROM(KBOUT,'Matching region too long in JALIGN')
        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
      IF(X.LT.PERMAX) THEN
        IC = CLINNO(LNBR,IDBSIZ,NCONTS,JCONN)
        IF(IC.EQ.0) THEN
          CALL ERROM(KBOUT,'Error: contig line not found')
          IFAIL = 99
          RETURN
        END IF
        IF(JSENSE.EQ.-1) THEN
          STRAND = '-'
          IF(IEND.EQ.1) THEN
C
C  probe is complement of right hand end of contig. Give posns assuming
C  this contig is complemented.
C
            IENDGT = IENDG - IRADD(JCON)
C
C Next line gives posns relative to original orientation
C            IENDGT = RELPG(IC) + IRADD(JCON) - IENDG + 1
          ELSE
C
C  probe is complement of left end of contig. Give posns assuming this
C  contig is going to be complemented.
C
            IENDGT = RELPG(IC) - WINDOW + ILADD(JCON) + IENDG
          END IF
        ELSE
          STRAND = '+'
          IF(IEND.EQ.2) THEN
C
C  probe is left hand end of contig in original sense
C
            IENDGT = IENDG - ILADD(JCON)
          ELSE
C
C  probe is right hand end of contig in original sense
C
            IENDGT = RELPG(IC) + IRADD(JCON) - WINDOW + IENDG
          END IF
        END IF
        IENDCT = IENDC - ILADD(MCON)
          WRITE(IDEV,*)
     +    ' Possible join between contig ',JCONN,' in the ',
     +    STRAND,' sense and contig ',NCON
        WRITE(IDEV,1000)X
1000    FORMAT(' Percentage mismatch after alignment = ',F4.1)
        WRITE(NAME1,1002)JCONN
        WRITE(NAME2,1002)NCON
 1002   FORMAT(I6)
        CALL FMT4LP(SEQC2(1),SEQG2(IENDG),LO,IENDCT,IENDGT,IDEV,
     +  NAME2,NAME1)
        NFOUND = NFOUND + 1
      END IF
      IFAIL=0
      END
      SUBROUTINE ADISM5(IDIM,IDIMG,SAVPS,SAVPG,IDSAV,
     +CENDS,NENDS,IDCEND,MAXCON,ILEFTS,ILC,IPOSC,IPOSG,ISENSE,
     +LLINO,IMATC,ISTRAN,MAXC,KBOUT,MCON)
C   AUTHOR: RODGER STADEN
      INTEGER ILEFTS(MAXC),ILC(MAXC),IPOSC(MAXC),IPOSG(MAXC)
      INTEGER ISENSE(MAXC),LLINO(MAXC),MCON(MAXC)
      INTEGER CENDS(MAXCON)
      INTEGER NENDS(MAXCON)
      INTEGER SAVPS(IDSAV),SAVPG(IDSAV)
      NEXTC=IDIM+1
      CALL BUB2AS(SAVPS,SAVPG,IDSAV)
        IMATC=IMATC+1
        CALL ADISM6(SAVPS(1),SAVPG(1),CENDS,NENDS,IDCEND,MAXCON,
     +  ILEFTS,ILC,IPOSC,IPOSG,ISENSE,LLINO,IMATC,ISTRAN,NEXTC,MAXC,
     +  KBOUT,MCON)
      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 ADISM6(SAVPS(I),SAVPG(I),CENDS,NENDS,IDCEND,MAXCON,
     +  ILEFTS,ILC,IPOSC,IPOSG,ISENSE,LLINO,IMATC,ISTRAN,NEXTC,MAXC,
     +  KBOUT,MCON)
        LEND=IDIMG-SAVPG(I)+SAVPS(I)
10    CONTINUE
      IMATC = MIN(IMATC,MAXC)
      END
      SUBROUTINE ADISM6(ISAVPS,SAVPG,CENDS,NENDS,
     +IDCEND,MAXCON,ILEFTS,ILC,IPOSC,IPOSG,ISENSE,LLINO,IMATC,ISTRAN,
     +NEXTC,MAXC,KBOUT,MCON)
C   AUTHOR: RODGER STADEN
      INTEGER ILEFTS(MAXC),ILC(MAXC),IPOSC(MAXC),IPOSG(MAXC)
      INTEGER ISENSE(MAXC),LLINO(MAXC),MCON(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
C new bit need to save contig number for alinej
      SAVPS=SAVPS-1
      LCL=SAVPS-CENDS(JJ)
      LCR=CENDS(JJ+1)-ISAVPS-1
      NEXTC=CENDS(JJ+1)+20
      IF(IMATC.LE.MAXC) THEN
        MCON(IMATC) = JJ
        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
      ELSE
        CALL ERROM(KBOUT,'Warning: too many overlaps')
      END IF
      END
C      JCONS
      SUBROUTINE JCONS(RELPG,LNGTHG,LNBR,RNBR,NAMPRO,NGELS,NCONTS,
     +SEQ1,IDIM1,GEL,IDBSIZ,ISTART,JOB,LLINO,LINCON,LREG,RREG,TEMP,
     +CHRSIZ,MAXGL2,KBOUT,
     +IDEVW,IFAIL,MAXGEL,IDM,PERCD,TGEL,ILADD,IRADD,MAXCON,JCON,
     +IWIN,NBAD)
C   AUTHOR: RODGER STADEN
      INTEGER RELPG(IDBSIZ),CHRSIZ,ILADD(MAXCON),IRADD(MAXCON)
      INTEGER LREG,RREG,X,Y,TEMP(CHRSIZ,MAXGL2)
      CHARACTER SEQ1(IDIM1)
      INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
      CHARACTER GEL(MAXGEL),TGEL(MAXGEL)
      CHARACTER NAMPRO*(*)
      CALL BUSY(KBOUT)
C      WRITE(*,*)'NGELS,NCONTS,IDIM1,ISTART,LREG,RREG'
C      WRITE(*,*)NGELS,NCONTS,IDIM1,ISTART,LREG,RREG
C JOB = 0 do all contigs, = 1 do one contig llino,lincon
      IFAIL=0
      IF (JOB.EQ.0) THEN
        N=IDBSIZ-NCONTS
        NCONS = 0
        DO 110 I=N,IDBSIZ-1
          J=LNBR(I)
          X=1
          Y=RELPG(I)
          ISTART=ISTART+1
          IF((ISTART+19+Y+2*MAXGEL).GT.IDIM1)THEN
            WRITE(KBOUT,1009)IDIM1
1009        FORMAT(
     +      ' Maximum consensus length(',I6,') exceeded',/,
     +      ' calculation aborted')
            IFAIL=1
            RETURN
          END IF
          CALL ADDTIT(SEQ1(ISTART),NAMPRO,J,ISTART)
          NCONS = NCONS + 1
          IDIN = 0
          IF(IWIN.GT.0) THEN
            IDIN = MAXGEL
            CALL GETEX(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,I,1,
     +      GEL,TGEL,IDIN,IWIN,NBAD)
            IF(IDIN.GT.0)CALL SQCOPY(GEL,SEQ1(ISTART),IDIN)
          END IF
          ILADD(NCONS) = IDIN
          ISTART = ISTART + IDIN
          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-1
          IDIN = 0
          IF(IWIN.GT.0) THEN
            IDIN = MAXGEL
            CALL GETEX(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,I,2,
     +      GEL,TGEL,IDIN,IWIN,NBAD)
            IF(IDIN.GT.0)CALL SQCOPY(GEL,SEQ1(ISTART+1),IDIN)
          END IF
          IRADD(NCONS) = IDIN
          ISTART = ISTART + IDIN
110     CONTINUE
      ELSE
C
C do it for one contig
C
        J = LLINO
        I = LINCON
        X = LREG
        Y = RREG
        ISTART = ISTART + 1
C        WRITE(*,*)
C     +'LLINO,LINCON,NCONTS,ISTART',LLINO,LINCON,NCONTS,ISTART
        IF((ISTART+19+Y+2*MAXGEL).GT.IDIM1)THEN
          WRITE(KBOUT,1009)IDIM1
          IFAIL=1
          RETURN
        END IF
        CALL ADDTIT(SEQ1(ISTART),NAMPRO,J,ISTART)
        NCONS = NCONTS
        IDIN = 0
        IF(IWIN.GT.0) THEN
          IDIN = MAXGEL
          CALL GETEX(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,I,1,
     +      GEL,TGEL,IDIN,IWIN,NBAD)
          IF(IDIN.GT.0)CALL SQCOPY(GEL,SEQ1(ISTART),IDIN)
        END IF
C        WRITE(*,*)'ILADD(JCON)',IDIN
        ILADD(JCON) = IDIN
        ISTART = ISTART + IDIN
        CALL SUMMER(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +    SEQ1(ISTART),Y,GEL,X,Y,J,IDBSIZ,TEMP,CHRSIZ,MAXGL2,
     +    IDEVW,MAXGEL,IDM,PERCD)
C repleced by next line 26-1-93        ISTART = ISTART + Y - 1
        ISTART = ISTART + RREG - LREG
        IDIN = 0
        IF(IWIN.GT.0) THEN
          IDIN = MAXGEL
          CALL GETEX(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,I,2,
     +      GEL,TGEL,IDIN,IWIN,NBAD)
          IF(IDIN.GT.0)CALL SQCOPY(GEL,SEQ1(ISTART+1),IDIN)
        END IF
C        WRITE(*,*)'IRADD(JCON)',IDIN
        IRADD(JCON) = IDIN
        ISTART = ISTART + IDIN
      END IF
      END
      SUBROUTINE GETEX(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,ICONT,IEND,
     +GEL,GELT,ID,IWIN,NBAD)
      INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ),RELPG(IDBSIZ)
      CHARACTER GEL(ID),GELT(ID)
      EXTERNAL NOK2
      MAXGEL = ID
      IDT = 0
C routine to find a possible extension to a contig by looking in a tag file
C contig ICONT end IEND = 1 =left 2=right
C return data in GEL, of length ID
C The worst aspect of this is that if we dont choose the very end reading
C we dont know where it lies relative to the consensus. For now just assume
C there are no length difference between the extension and the consensus
C and just add it on the end
      IF(IEND.EQ.1) THEN
        LMOST = 1
        IGEL = LNBR(ICONT)
 10     CONTINUE
        IF(IGEL.EQ.0) GO TO 100
        IF(RELPG(IGEL).GT.MAXGEL) GO TO 100
        IF(LNGTHG(IGEL).LT.0) THEN
          ID = MAXGEL
          CALL GETEXT(IGEL,GELT,ID,IOK)
          IF(IOK.EQ.0) THEN
C  look for number of n's here and change id accordingly
            K =  NOK2(GELT,ID,IWIN,NBAD)
            LT = MIN(LMOST,RELPG(IGEL)-K)
            IF(LT.LT.LMOST) THEN
              IS = RELPG(IGEL)
              N = K - IS + 1
              CALL SQCOPY(GELT(IS),GEL,N)
              CALL SQREV(GEL,N)
              CALL SQCOM(GEL,N)
              IDT = N
              LMOST = LT
            END IF
          ELSE
C            WRITE(*,*)'COCKUP IN GETEXT, gel',IGEL
          END IF
        END IF
        IGEL = RNBR(IGEL)
        GO TO 10
      ELSE
        IGEL = RNBR(ICONT)
        LMOST = RELPG(ICONT)
        IDC = RELPG(ICONT)
 20     CONTINUE
        IF(IGEL.EQ.0) GO TO 100
        IF(LMOST-RELPG(IGEL).GT.MAXGEL) GO TO 100
        IF(LNGTHG(IGEL).GT.0) THEN
          ID = MAXGEL
          CALL GETEXT(IGEL,GELT,ID,IOK)
          IF(IOK.EQ.0) THEN
            K =  NOK2(GELT,ID,IWIN,NBAD)
            LT = MAX(LMOST,RELPG(IGEL)+LNGTHG(IGEL)+K-1)
            IF(LT.GT.LMOST) THEN
              IS = RELPG(ICONT) - (RELPG(IGEL) + LNGTHG(IGEL)) + 2
              N = K - IS + 1
              CALL SQCOPY(GELT(IS),GEL,N)
              IDT = N
              LMOST = LT
            END IF
          ELSE
C            WRITE(*,*)'COCKUP IN GETEXT, GEL',IGEL
          END IF
        END IF
        IGEL = LNBR(IGEL)
        GO TO 20
      END IF
 100  CONTINUE
      ID = IDT
      END
      INTEGER FUNCTION NOK2(GEL,ID,IWIN,NBADIN)
      CHARACTER GEL(ID)
      PARAMETER (MAXPOS = 101)
      INTEGER POSNS(MAXPOS),R
      EXTERNAL KWRAP
C count N's over a window of iwin, return position
C when over NBAD
C INIT
      NBAD = NBADIN + 1
      I = 0
      N = 0
      NOK2 = ID
      L = 1
      R = 0
      IF(NBAD.GT.MAXPOS)THEN
        WRITE(*,*)'Scream: nok2 not happy'
        RETURN
      END IF
 10   CONTINUE
      I = I + 1
      IF(I.GT.ID) RETURN
      IF(GEL(I).EQ.'-') THEN
        N = N + 1
        R = KWRAP(R,NBAD)
        POSNS(R) = I
        IF(N.GE.NBAD) THEN
          IF(POSNS(R)-POSNS(L)+1.LT.IWIN) THEN
            NOK2 = POSNS(L)
            RETURN
          END IF
          L = KWRAP(L,NBAD)
        END IF
      END IF
      GO TO 10
      END
      INTEGER FUNCTION KWRAP(I,J)
      IT = I + 1
      IF(IT.GT.J) IT = 1
      KWRAP = IT
      END
      SUBROUTINE PADSHF(RELPG,LNGTHG,LNBR,RNBR,
     +READS,IDIM1,LREG,RREG,LLINO,IDBSIZ,FREQS,CHRSIZ,MAXGL2,
     +IDEVW,MAXGEL,READPS,READNS,PSTART,NPADS,MXG,PADPOS,MAXP,
     +KBOUT)
C   AUTHOR: RODGER STADEN
      INTEGER RELPG(IDBSIZ),CHRSIZ
      INTEGER LREG,RREG
      INTEGER LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
      CHARACTER READS(IDIM1),PAD,DASH
C      PARAMETER (MXG = 1000)
C      PARAMETER (MAXP = MXG * 20)
      INTEGER FREQS(CHRSIZ,MAXGL2),READPS(MXG),READNS(MXG)
      INTEGER CR,SHIFTF,READST,PCF,WINS,WINE,PG,PC,PCR,CHNRP1
      INTEGER PADPOS(MAXP),PSTART(MXG),NPADS(MXG),PADST,PGE
      LOGICAL FIRSTP,PASS1
      EXTERNAL INDEXS,CHNRP1,NSAMPL
      SAVE PAD,DASH
      DATA PAD/'*'/,DASH/'-'/
C
C region to process is lreg to rreg
C current active region is wins to wine
C current reading is cr
C we process all the readings covering wins to wine,
C write them to disk, then move wins and wine, and get the first
C reading that covers them, etc
C we save readings in reads and their numbers in readns
C and their start positions in reads in readps
C we accumulate frequencies in freqs
C
      NEDITS = 0
      NSWAPT = 0
      INDPAD = INDEXS(PAD,JUNK)
      WINS = LREG
      WINE = MIN(WINS + MAXGL2 - 1,RREG)
1     CONTINUE
      CR =  CHNRP1(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,
     +  LLINO,WINS)
      IF (CR.EQ.0) RETURN
      DO 10 I = 1,MAXGL2
        DO 10 J = 1,CHRSIZ
           FREQS(J,I) = 0
10    CONTINUE
      NREADS = 0
      READST = 1
      PADST  = 1
      PASS1  = .TRUE.
20    CONTINUE
      CALL READW(IDEVW,CR,READS(READST),MAXGEL)
      IF (NREADS.EQ.MXG) THEN
        CALL ERROM(KBOUT,'Too many reads for buffer')
        RETURN
      END IF
      NREADS = NREADS + 1
      READNS(NREADS) = CR
      READPS(NREADS) = READST
      READST = READST + ABS(LNGTHG(CR))
      SHIFTF = RELPG(CR) - WINS
      DO 30 I = MAX(1,WINS-RELPG(CR) + 1),
     +          MIN(ABS(LNGTHG(CR)),WINE-RELPG(CR)+1)
        JJ = INDEXS(READS(READPS(NREADS)+I-1),JSCORE)
        JJJ = SHIFTF + I
        FREQS(JJ,JJJ) = FREQS(JJ,JJJ) + 1
30    CONTINUE
      IF (RNBR(CR).NE.0) THEN
        CR = RNBR(CR)
        IF (RELPG(CR).LE.WINE) GO TO 20
      END IF
      DO 35 I=1,NREADS
        NPADS(I) = 0
 35   CONTINUE
40    CONTINUE
      NSWAP = 0
C pg is position in reading ir
C PCR is position in reads
C pc is position in contig
C pcf is position in freqs
C
C we swap if chars to left and right are not already pads and
C theres at least one of the char to the left in the current column
C or the char to the left is a dash (not always beneficial) and
C the pads are not already aligned with only 1 other symbol
C
C we put the element number of the first pad for each reading at padst
C we count the number of pads in npads
C we store the pad positions in padpos
C
      DO 60 IR = 1,NREADS
        SHIFTF = WINS - 1
        FIRSTP = .TRUE.
        DO 50 PG = MAX(2,WINS-RELPG(READNS(IR))+2),
     +  MIN(ABS(LNGTHG(READNS(IR))),WINE-RELPG(READNS(IR))+1)
          PCR = PG + READPS(IR) - 1
C
C horrible exception for case where base 1 in read is pad
C we wont see it this pass but will when we write out tags
C so make sure we do see it now or we cockup later
C
          IF (PASS1) THEN
            IF (PG.EQ.2) THEN
              IF (READS(PCR-1).EQ.PAD) THEN
                PSTART(IR) = PADST
                NPADS(IR) = NPADS(IR) + 1
                PADPOS(PADST) = PG - 1
                IF (PADST.EQ.MAXP) THEN
                  CALL ERROM(KBOUT,'Too many pads for buffer')
                  RETURN
                END IF
                PADST = PADST + 1
                FIRSTP = .FALSE.
              END IF
            END IF
          END IF
          IF (READS(PCR).EQ.PAD) THEN
            IF (PASS1) THEN
              IF (FIRSTP) PSTART(IR) = PADST
              NPADS(IR) = NPADS(IR) + 1
              PADPOS(PADST) = PG
              IF (PADST.EQ.MAXP) THEN
                CALL ERROM(KBOUT,'Too many pads for buffer')
                RETURN
              END IF
              PADST = PADST + 1
              FIRSTP = .FALSE.
            END IF
            PC = PG + RELPG(READNS(IR)) - 1
            INPCRM = INDEXS(READS(PCR-1),JSCORM)
            IF (INPCRM.NE.INDPAD) THEN
              PCF = PC - SHIFTF
              IF (((FREQS(INPCRM,PCF).NE.0).OR.
     +        (READS(PCR-1).EQ.DASH)).AND.
     +        (FREQS(INDPAD,PCF).LT.(NSAMPL(FREQS(1,PCF),CHRSIZ)-1)))
     +        THEN
C
C swap
C
                READS(PCR) = READS(PCR-1)
                READS(PCR-1) = PAD
                INPCR = INDEXS(READS(PCR),JSCORE)
                FREQS(INPCRM,PCF-1) = FREQS(INPCRM,PCF-1) - 1
                FREQS(INPCR,PCF)    = FREQS(INPCR,PCF)    - 1
                FREQS(INPCR,PCF-1)  = FREQS(INPCR,PCF-1)  + 1
                FREQS(INPCRM,PCF)   = FREQS(INPCRM,PCF)   + 1
                NSWAP = NSWAP + 1
              END IF
            END IF
          END IF
50      CONTINUE
60    CONTINUE
C      WRITE(*,*)'NUMBER OF SWAPS',NSWAP
      NSWAPT = NSWAPT + NSWAP
      PASS1 = .FALSE.
      IF (NSWAP.GT.0) GO TO 40
C
C no more movement so write back wot weve changed so far
C
      DO 70 IR = 1,NREADS
        K = 0
        NPAD = 0
        DO 65 PG = MAX(1,WINS-RELPG(READNS(IR))+1),
     +  MIN(ABS(LNGTHG(READNS(IR))),WINE-RELPG(READNS(IR))+1)
          PCR = PG + READPS(IR) - 1
          IF (READS(PCR).EQ.PAD) THEN
            L = PADPOS(PSTART(IR)+NPAD)
            IF (PG.LT.L) THEN
              PC = PG + RELPG(READNS(IR)) - 1
              LE = L
              PGE = PG
              IF (LNGTHG(READNS(IR)).LT.0) THEN
                LE = 1 - LNGTHG(READNS(IR)) - LE
                PGE = 1 - LNGTHG(READNS(IR)) - PGE
C         WRITE(*,*)READNS(IR),' insert at',PGE,PC,' del at',LE
                CALL DELEDT(READNS(IR),LE,'*')
                CALL INSEDT(READNS(IR),PGE,'*')
              ELSE
C         WRITE(*,*)READNS(IR),' del at',LE,' insert at',PGE,PC
                CALL DELEDT(READNS(IR),LE,'*')
                CALL INSEDT(READNS(IR),PGE,'*')
              END IF
              NEDITS = NEDITS + 1
            END IF
            NPAD = NPAD + 1
          END IF
 65     CONTINUE
        CALL WRITEW(IDEVW,READNS(IR),READS(READPS(IR)),MAXGEL)
70    CONTINUE
C
C we allow the next chunk to overlap the previous one by 20
C in case some pads at the right edge of it could still move
C further left. Alternatively we could look for 2 adjacent
C positions which have 100% consensus and are different
C
      IF (WINE.NE.RREG) THEN
        WINS = MAX(LREG,WINE-19)
        WINE = MIN(WINS + MAXGL2 - 1,RREG)
        GO TO 1
      END IF
C      WRITE(*,*)'Total swaps',NSWAPT
      WRITE(KBOUT,*)'Number of pads moved',NEDITS
      END
      INTEGER FUNCTION NSAMPL(COUNTS,IDM)
C
C count the number of reads covering this position
C
      INTEGER IDM
      INTEGER COUNTS(IDM)
      ISUM = 0
      DO 5 I=1,IDM
        ISUM = ISUM + COUNTS(I)
 5    CONTINUE
      NSAMPL = ISUM
      END
      INTEGER FUNCTION CONOK(
     +RELPG,LNGTHG,LNBR,RNBR,NAMPRO,NGELS,NCONTS,
     +SEQ,MAXSEQ,SEQ2,IDBSIZ,TEMP3,
     +ECHRSZ,MAXGL2,KBOUT,IDEVW,IDEV,
     +MAXGEL,IDM,PERCD,CENDS,NENDS,MAXCON)
      INTEGER RELPG(IDBSIZ),LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
      INTEGER ECHRSZ,TEMP3(ECHRSZ,MAXGL2),CENDS(MAXCON),NENDS(MAXCON)
      CHARACTER SEQ(MAXSEQ),SEQ2(MAXGEL),NAMPRO*(*)
      EXTERNAL NOK2
C
C routine to calc a consensus and look for ibad dashes in iwin bases
C
C returns number of cocked-up contigs or -1 for error in consensus calc
C for each contig it stops where it find the first problem.
C
      CONOK = 0
      JOB = 0
      IDIM1 = 0
      CALL ACONSN(RELPG,LNGTHG,LNBR,RNBR,NAMPRO,NGELS,NCONTS,
     +SEQ,MAXSEQ,SEQ2,IDBSIZ,IDIM1,JOB,KDUMM,KDUMM,KDUMM,TEMP3,
     +ECHRSZ,MAXGL2,KBOUT,IDEVW,IFAIL,MAXGEL,IDM,PERCD)
      IF(IFAIL.NE.0) THEN
        CALL ERROM(KBOUT,'Error calculating consensus')
        CONOK = -1
        RETURN
      END IF
      CALL FNDCON(SEQ,IDIM1,CENDS,NENDS,IDCEND,MAXCON,KBOUT)
      IWIN = 20
      NBAD = 15
      DO 10 I=1,IDCEND
        J = CENDS(I) + 20
        IDIM = CENDS(I+1) - J
        K =  NOK2(SEQ(J),IDIM,IWIN,NBAD)
        IF (K.LT.IDIM) THEN
          WRITE(IDEV,*)'Problem at position',K,' In contig',NENDS(I)
          CONOK = CONOK + 1
        END IF
 10   CONTINUE
      IF (CONOK.EQ.0) THEN
        WRITE(KBOUT,*)
     +' Consensus has no segments with',NBAD,' dashes in',IWIN
      ELSE
        WRITE(KBOUT,*)
     +  CONOK,' contigs have segments with',NBAD,' dashes in',IWIN
      END IF
      END
      SUBROUTINE AUTOM(RELPG,LNGTHG,LNBR,RNBR,MAXDB,IDBSIZ,
     +NGELS,NCONTS,LLINO,LINCON,MAXGEL,
     +TEMP3,SEQ1,MAXSEQ,SEQ2,SEQ5,SEQC2,SEQG2,
     +MAXGLM,MAXGL2,ECHRSZ,
     +SAV1,SAV2,SAV3,MAXSAV,
     +KBIN,KBOUT,IDEV1,IDEV2,IDEV3,IDEV8,IDEV,
     +IHELPS,IHELPE,HELPF,IDEVH,NAMARC,NAMPRO,FILE,
     +PERCD,IOPEN,IDM,SEQG3,SEQC3,IOK,IDEVC,IDEVT)
      INTEGER ECHRSZ,SELCON
      INTEGER RELPG(MAXDB)
      INTEGER LNGTHG(MAXDB),LNBR(MAXDB),RNBR(MAXDB)
      INTEGER TEMP3(ECHRSZ,MAXGL2)
      CHARACTER SEQC2(MAXGLM,2),SEQG2(MAXGLM,2)
      CHARACTER SEQ1(MAXSEQ),SEQ2(MAXGLM)
      INTEGER SAV1(MAXSAV),SAV2(MAXSAV),SAV3(MAXSAV)
      CHARACTER NAMARC*(*),NAMPRO*(*),FILE*(*)
      CHARACTER SEQ5(MAXGLM),HELPF*(*),SEQG3(MAXGLM),SEQC3(MAXGLM)
C
C take the poor data from reads to see if it aligns with the consensus
C
      CALL DBCHEK(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,
     +  TEMP3,IERR,KBOUT)
      IF(IERR.GT.1) RETURN
      IFAIL = 0
      IF(NGELS.LT.1) RETURN
C      MN = 0
C      MX = 50
C      MAXPG = 20
C      CALL GETINT(MN,MX,MAXPG,
C     +'Maximum pads per sequence',
C     +IVAL,KBIN,KBOUT,
C     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
C      IF(IOK.NE.0) RETURN
      MAXPG = IVAL
      MAXPC = IVAL
      RMN = 0.
      RMX = 100.
      PERMAX = 13.
      CALL GETRL(RMN,RMX,PERMAX,
     +  'Maximum percent mismatch after alignment',
     +  VAL,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      PERMAX = VAL
      MN = 1
      MX = MAXGEL
      IWING = 100
      CALL GETINT(MN,MX,IWING,
     +   'Window size for good data scan',
     +   IVAL,KBIN,KBOUT,
     +   IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      IWING = IVAL
      MN = 1
      MX = MIN(100,IWING)
      NBAD = MIN(IWING,5)
      CALL GETINT(MN,MX,NBAD,
     +   'Maximum number of dashes in scan window',
     +   IVAL,KBIN,KBOUT,
     +   IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      NBAD = IVAL
      CALL YESNO(IREPN,'Save failed names in a file',
     +  IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF (IREPN.LT.0) RETURN
      IF (IREPN.EQ.0) THEN
        CALL OPENF1(IDEV8,FILE,1,IOK,KBIN,KBOUT,
     +  'File for names of failed reads',
     +  IHELPS,IHELPE,HELPF,IDEVH)
        IF (IOK.NE.0) RETURN
      END IF
      CALL YESNO(SELCON,'Select contigs',
     +  IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IF(SELCON.LT.0) GO TO 100
      IF(SELCON.EQ.0) THEN
        CALL GETLN3(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,LINCON,
     +  LLINO,NULGEL,IOK,IDBSIZ,KBIN,KBOUT,IDEV3,
     +  'Contig identifier',
     +  IHELPS,IHELPE,HELPF,IDEVH)
        IF(IOK.NE.0) GO TO 100
        CALL GETREG(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +  1,RELPG(LINCON),LREG,RREG,LINCON,LLINO,IDBSIZ,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.0) GO TO 100
      END IF
       IDIM2=MAXGEL
      CALL AUTOMN(SEQ1,MAXSEQ,SEQ2,IDIM2,
     +LLINO,LINCON,IFCOMP,LREG,RREG,
     +IDEV,MAXGEL,MAXGLM,
     +SAV1,SAV2,SAV3,MAXSAV,
     +SEQG2,SEQC2,
     +PERMAX,SEQG3,SEQC3,
     +RELPG,LNBR,IDBSIZ,NGELS,NCONTS,
     +LNGTHG,RNBR,IDEV1,IDEV2,IDEV3,IDEVT,IDEVC,PERCD,IWING,NBAD,
     +ECHRSZ,TEMP3,MAXGL2,IDM,NAMPRO,KBIN,KBOUT,SELCON,IREPN,IDEV8,
     +IHELPS,IHELPE,HELPF,IDEVH)
 100  CONTINUE
      IF(IREPN.EQ.0) CLOSE(UNIT=IDEV8)
      END
      SUBROUTINE AUTOMN(SEQ1,MAXSEQ,GEL,IDIMGI,
     +LLINO,LINCON,IFCOMP,LREG,RREG,
     +IDEV,MAXGEL,MAXGLM,
     +SAVPS,SAVPG,SAVL,MAXSAV,
     +SEQG2,SEQC2,
     +PERMAX,SEQG3,SEQC3,
     +RELPG,LNBR,IDBSIZ,NGELS,NCONTS,
     +LNGTHG,RNBR,IDEV1,IDEV2,IDEV3,IDEVT,IDEVC,PERCD,IWING,NBAD,
     +ECHRSZ,TEMP3,MAXGL2,IDM,NAMPRO,KBIN,KBOUT,SELCON,IREPN,IDEV8,
     +IHELPS,IHELPE,HELPF,IDEVH)
C   AUTHOR: RODGER STADEN
      INTEGER ECHRSZ
      INTEGER SAVPS(MAXSAV),SAVPG(MAXSAV),SAVL(MAXSAV)
      CHARACTER NAMPRO*(*),HELPF*(*)
      CHARACTER SEQ1(MAXSEQ),GEL(MAXGLM)
      CHARACTER SEQG2(MAXGLM,2),SEQC2(MAXGLM,2)
      CHARACTER SEQG3(MAXGLM),SEQC3(MAXGLM)
      CHARACTER NAMT*16
      PARAMETER (MAXCON = 1,MING = 10,MAXG = 500)
      INTEGER ILADD(MAXCON),IRADD(MAXCON)
      INTEGER RREG,FIRSTR,SELCON,FIRSTC
      INTEGER RELPG(IDBSIZ),LNBR(IDBSIZ),LNGTHG(IDBSIZ),RNBR(IDBSIZ)
      INTEGER TEMP3(ECHRSZ,MAXGL2)
      INTEGER CHNRP1,XVERSN
      EXTERNAL CHNRP1,XVERSN,NOK2
      JOB = 1
      JCON =  1
      NPROBS = 0
      IF (SELCON.EQ.0) THEN
        FIRSTC = LINCON
        LASTC  = LINCON
      ELSE IF (SELCON.EQ.1) THEN
        FIRSTC = IDBSIZ-NCONTS
        LASTC  = IDBSIZ-1
      ELSE
        CALL ERROM(KBOUT,'Error in AUTOM: unexpected option')
        RETURN
      END IF
      DO 50 ICONT = FIRSTC,LASTC
        IF (SELCON.EQ.1) THEN
          LINCON = ICONT
          LLINO = LNBR(LINCON)
          LREG = 1
          RREG = RELPG(LINCON)
        END IF          
        IDIM = 0
        CALL JCONS(RELPG,LNGTHG,LNBR,RNBR,NAMPRO,NGELS,NCONTS,
     +   SEQ1,MAXSEQ,GEL,IDBSIZ,IDIM,JOB,LLINO,LINCON,LREG,RREG,
     +   TEMP3,
     +    ECHRSZ,MAXGL2,KBOUT,IDEV2,IOK,MAXGEL,IDM,PERCD,SEQG3,
     +    ILADD,IRADD,MAXCON,JCON,0,NBAD)
        IF (IOK.NE.0) RETURN
C      CALL FMTDB(SEQ1,IDIM,1,IDIM,60,KBOUT)
        LENCON = RREG - LREG + 1
        ISTRAN = 1
 5      CONTINUE
C
C main loop
C
        FIRSTR = CHNRP1(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,
     +  LNBR(LINCON),LREG)
        IF(FIRSTR.EQ.0) GO TO 50
        IRNO = FIRSTR
 10     CONTINUE
        IF (LNGTHG(IRNO).GT.0) THEN
          IDIN = MIN(MAXG-LNGTHG(IRNO)+1,MAXGLM)
          IF(IDIN.GT.MING) THEN
            CALL GETEXT(IRNO,GEL,IDIN,IOK)
            IF(IOK.EQ.0) THEN
              K = NOK2(GEL,IDIN,IWING,NBAD)
              IDIN = K
            ELSE
              IDIN = 0
            END IF
          ELSE
            IDIN = 0
          END IF
C
C fudge idin (it seems to return 1 less char than its value!)
C
          IDIN = IDIN - 2
C        WRITE(*,*)'IDIN',IDIN
          IF(IDIN.GT.MING) THEN
C
C trim gel if it goes off the end of the consensus!
C
            IDIN = MIN((LENCON-(RELPG(IRNO)+LNGTHG(IRNO)-1)),IDIN)
C          CALL FMTDB(GEL,IDIN,1,IDIN,60,KBOUT)
            JDIM22 = IDIN
            JDOUT = MAXGEL
            IDSAV = MAXSAV
            JPOSC = RELPG(IRNO)+LNGTHG(IRNO) - LREG + 1
            LC = LENCON - JPOSC + 1
            IPC = RELPG(IRNO) + LNGTHG(IRNO) - 1
C
C fudge the consensus position as we dont seem to get alignments for
C cases where a deletion is required at the start of the consensus
C
C          CALL ALINEM(SEQ1(20+JPOSC),GEL,SEQG3,SEQC3,
            CALL ALINEM(SEQ1(18+JPOSC),GEL,SEQG3,SEQC3,
     +      SAVPS,SAVPG,SAVL,IDSAV,LC,JDIM22,JDOUT,
     +      1,1,
     +      JFAIL,PERMAX,KBOUT,IDEV,
     +      MAXGEL,PERMS,IPC,IRNO,LNBR(LINCON),IFAIL)
            IF (IFAIL.EQ.0) THEN
              IF (JFAIL.NE.0) NPROBS = NPROBS + 1
              IF ((JFAIL.NE.0).AND.(IREPN.EQ.0)) THEN
                CALL READN(IDEV3,IRNO,NAMT)
                WRITE(IDEV8,1000)NAMT,IRNO,LLINO,IPC
 1000           FORMAT(' ',A,' ',3I6)
              END IF
              IF((JFAIL.NE.0).AND.(XVERSN().NE.0).AND.(IDEV.EQ.KBOUT)) 
     +          THEN
                CALL BPAUSE(KBIN,KBOUT,IOK)
                IF (IOK.NE.0) GO TO 100
                CALL YESNO(IJOIN,'Use the editor',
     +          IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
                IF(IJOIN.LT.0) GO TO 100
                IF (IJOIN.EQ.0) THEN
                  CALL CXEDIT(IDEV1,IDEV2,IDEV3,IDEVT,IDEVC,
     +            RELPG,LNGTHG,LNBR,RNBR,MAXGEL,
     +            IDBSIZ,LINCON,LNBR(LINCON),IRNO,LNGTHG(IRNO),
     +            PERCD,IDM,1,IOK)
                END IF
                CALL BUSY(KBOUT)
              END IF
            END IF
          END IF
        END IF
        IRNO = RNBR(IRNO)
        IF(IRNO.NE.0) THEN
          IF((RELPG(IRNO)+LNGTHG(IRNO)).LT.RREG) GO TO 10
        END IF
        IF (ISTRAN.EQ.1) THEN
          CALL CMPLMT(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,LINCON,
     +    LNBR(LINCON),GEL,IDBSIZ,KBOUT,IDEV1,IDEV2,MAXGEL)
          LREG = RELPG(LINCON) - RREG + 1
          RREG = LREG + LENCON - 1
          CALL SQREV(SEQ1(21),LENCON)
          CALL SQCOM(SEQ1(21),LENCON)
          ISTRAN = 2
          GO TO 5
        END IF
        CALL CMPLMT(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,LINCON,
     +  LNBR(LINCON),GEL,IDBSIZ,KBOUT,IDEV1,IDEV2,MAXGEL)
        ISTRAN  = 3
 50   CONTINUE
 100  CONTINUE
      WRITE(KBOUT,*)'Number of possible problems ',NPROBS
C
C if required return the contig to original sense
C
      IF (ISTRAN.EQ.2) THEN
        CALL CMPLMT(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,LINCON,
     +  LNBR(LINCON),GEL,IDBSIZ,KBOUT,IDEV1,IDEV2,MAXGEL)
      END IF
      END
      SUBROUTINE ALINEM(SEQ1,SEQ2,SEQG2,SEQC2,ISAV1,ISAV2,ISAV3,
     +IDSAV,IDC,IDIM2,IDOUT,IC1,IG1,
     +IFAIL,PERMAX,KBOUT,IDEV,MAXGEL,PERCM,IPC,IRNO,LLINO,JFAIL)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ1(IDC),SEQ2(IDIM2),SEQG2(IDOUT),SEQC2(IDOUT)
      INTEGER ISAV1(IDSAV),ISAV2(IDSAV),ISAV3(IDSAV)
C      INTEGER PATH(5000)
      CHARACTER NAME1*6,NAME2*6
      PARAMETER (MINOVR = 10, MINSLT = 3)
      EXTERNAL PMIS
C
C the crap must be at least minovr bases in length or we dont bother
C
      JFAIL = 1
      IF((IDC.LT.MINOVR).OR.(IDIM2.LT.MINOVR)) RETURN
      WRITE(NAME1,1002)LLINO
      WRITE(NAME2,1002)IRNO
1002  FORMAT(I6)
      NAME1(1:1) = 'C'
      NAME2(1:1) = 'R'
      IDC1 = MIN(IDC,IDIM2)
      X = MAX(1.0,REAL(IDC1)/100.)
C
C allowing 10% and 7% of overlap to be pads: consensus and read respectively
C
      MAXPC = NINT(10.0*X)
      MAXPG = NINT(7.0*X)
      IPP=IDSAV
      CALL SLIDER(SEQ1,IDC,SEQ2,IDIM2,IC1,IG1,MAXPG,MAXPC,MINSLT,
     +ISAV1,ISAV2,ISAV3,IPP)
      IF((IPP.GT.IDSAV).OR.(IPP.LT.1)) THEN
        CALL ERROM(KBOUT,'Warning: slider failed')
        CALL ERROM(KBOUT,NAME2)
        RETURN
      END IF
      CALL REMOVL(ISAV2,ISAV3,ISAV1,IPP)
      CALL BUB3AS(ISAV2,ISAV3,ISAV1,IPP)
      CALL TPCHEK(ISAV2,ISAV3,ISAV1,IPP)
      CALL UPCHEK(ISAV2,ISAV3,ISAV1,IPP)
      CALL LINEUP(SEQ2,SEQ1,SEQG2,SEQC2,IDC,IDIM2,IDOUT,ISAV3,ISAV2,
     +ISAV1,IPP,ITOTPC,ITOTPG,JOINT,ITYPE,KBOUT,MAXGEL,JFAIL)
      IF(JFAIL.NE.0) THEN
        CALL ERROM(KBOUT,'Warning: lineup failed')
        CALL ERROM(KBOUT,NAME2)
        RETURN
      END IF
C      IDC1 = MIN(IDC,IDIM2+MAX(MAXPG,MAXPC))
C      IDC1 = MIN(IDC,IDIM2)
C      WRITE(*,*)'IDC,IDIM2',IDC,IDIM2
C      MMAXPC = -1*(MAXPC+MAXPC/2)
C      X = MAX(1.0,REAL(IDC1)/100.)
C      MMAXPC = NINT(-10.*X)
C      MMAXPG = NINT(7.*X)
C      MAXPC = -MMAXPC
C      MAXPG = MMAXPG
C      IDIM3 = IDC1
C      WRITE(*,*)'PADS ALLOWED',MAXPC,MAXPG
C      CALL GALIGN(SEQ1,IDC1,SEQ2,IDIM3,MMAXPC,MMAXPG,PATH)
C      CALL DISP(SEQ1,IDC1,SEQ2,IDIM3,PATH)
C      CALL EXPAND(SEQ1,IDC1,SEQ2,IDIM3,SEQC2,IDC2,SEQG2,IDG2,PATH)
C      LO = MIN(IDC2,IDG2)
C      WRITE(*,*)'IDC2,IDG2',IDC2,IDG2
C      LO = MIN(NOTIRL(SEQC2,IDC2,','),NOTIRL(SEQG2,IDG2,','))
C      WRITE(*,*)'LO',LO
C      END IF
      LO = MIN(IDOUT,IDIM2)
      PERCM = PMIS(SEQC2,SEQG2,LO)
      ITOTPC = NSYM(SEQC2,LO,',')
      ITOTPG = NSYM(SEQG2,LO,',')
      IFAIL = 0
      IF (ITOTPC.GT.MAXPC) IFAIL = 1
      IF (ITOTPG.GT.MAXPG) IFAIL = 1
      IF (PERCM.GT.PERMAX) IFAIL = 1
      IF(IFAIL.NE.0) THEN
        WRITE(IDEV,1000)PERCM,ITOTPC,ITOTPG
1000    FORMAT(' Percentage mismatch ',F4.1,', Pads',I4,I4)
        CALL FMT4LP(SEQC2(1),SEQG2,LO,IPC,1,IDEV,
     +  NAME1,NAME2)
        CALL BUSY(KBOUT)
      END IF
      END
      INTEGER FUNCTION NSYM(SEQ,ID,SYM)
      CHARACTER SEQ(ID),SYM
      N = 0
      DO 10 I=1,ID
        IF(SEQ(I).EQ.SYM) N = N + 1
 10   CONTINUE
      NSYM = N
      END
      REAL FUNCTION PMIS(SEQ1,SEQ2,ID)
      CHARACTER SEQ1(ID),SEQ2(ID),PAD
      PARAMETER (PAD  = ',')
C
C count mismatch. padding in consensus ignored
C
      J = 0
      DO 10 I=1,ID
        IF(SEQ1(I).NE.SEQ2(I)) THEN
          IF(SEQ1(I).NE.PAD) J = J + 1
        END IF
C        IF(SEQ1(I).NE.SEQ2(I)) J = J + 1
 10   CONTINUE
      PMIS = 100. * REAL(J)/REAL(ID)
      END
      SUBROUTINE UPCHEK(PC,PG,L,N)
      INTEGER PC(N),PG(N),L(N),DC,DG
C     AUTHOR RODGER STADEN
C
C only allow gaps that are shorter than the next block of identity
C
      K1 = 2
1     CONTINUE
      DO 10 I = K1,N
        J1 = I
        DC = PC(I) - PC(I-1) - L(I-1)
        DG = PG(I) - PG(I-1) - L(I-1)
        IF(ABS(DC-DG).GE.L(I)) GO TO 20
10    CONTINUE
      RETURN
20    CONTINUE
C      WRITE(*,*)'REMOVING!!'
        CALL ML(PC,PG,L,N,J1)
C      IF(L(J1-1).GT.L(J1)) THEN
C        CALL ML(PC,PG,L,N,J1)
C      ELSE
C        CALL ML(PC,PG,L,N,J1-1)
C      END IF
      K1 = MAX(2,J1-1)
      N = N - 1
      GO TO 1
      END
      SUBROUTINE ARRFIN(IDEV,SEQNCE,J,KBOUT,ICRAP)
      CHARACTER TEMP(80),SEQNCE(J)
      CHARACTER SPACE,TITCHR,GT
      EXTERNAL NOK2
      SAVE SPACE,TITCHR,GT
      PARAMETER (IWIN = 100, NBAD = 5)
      DATA SPACE/' '/
      DATA TITCHR/';'/
      DATA GT/'>'/
C
C routine to read reads, including their poor data if required
C allowing 5 n's in 100 bases
C
      IDMX=J
      J=0
1     CONTINUE
      READ(IDEV,1001,END=30,ERR=80)TEMP
1001  FORMAT(80A1)
      IF(TEMP(1).EQ.TITCHR) GO TO 1
      DO 20 I=1,80
        IF(TEMP(I).NE.SPACE)THEN
          IF(J.EQ.IDMX)THEN
            CALL ERROM(KBOUT,'Error in arrfin: too much data')
            RETURN
          END IF
          J=J+1
          SEQNCE(J)=TEMP(I)
        END IF
20    CONTINUE
      GO TO 1
30    CONTINUE
C      WRITE(*,*)' GOOD',J
      IF(ICRAP.NE.0) RETURN
C
C read in the crap
C
      REWIND(IDEV)
      JG = J
 50   CONTINUE
      READ(IDEV,1001,END=70,ERR=80)TEMP
      IF(TEMP(1).NE.TITCHR) GO TO 50
      IF(TEMP(2).EQ.GT) THEN
        DO 60 I=3,80
          IF(TEMP(I).NE.SPACE)THEN
            IF(J.EQ.IDMX)THEN
              CALL ERROM(KBOUT,'Error in arrfin: too much data')
              GO TO 70
            END IF
            J=J+1
            SEQNCE(J)=TEMP(I)
          END IF
60      CONTINUE
      END IF
      GO TO 50
70    CONTINUE
C      WRITE(*,*)' GOOD+BAD',J
      K = NOK2(SEQNCE(JG+1),J-JG+1,IWIN,NBAD)
      J = JG + K
C      WRITE(*,*)' GOOD+BAD-CRAP',J
C      WRITE(*,*)(SEQNCE(K),K=1,J)
      RETURN
 80   CONTINUE
      CALL ERROM(KBOUT,'Error reading file in arrfin')
      J = 0
      END
      SUBROUTINE DBLSTR(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,SEQ1,
     +IDIM1,GEL,IDBSIZ,TEMP3,ID1,CHRSIZ,MAXGL2,KBIN,KBOUT,IDEVW,
     +IDEVR,IDEV,LINLEN,PERCD,
     +IHELPS,IHELPE,FILEH,IDEVH,MAXGEL,IDEVN,
     +  LLINO,LINCON,LREG,RREG,MXGOOD,SEQ2,IDM,JOB,IERR,LSTRT,LEND)
      CHARACTER FILEH*(*)
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)
      CHARACTER SEQ1(IDIM1),SEQ2(IDIM1)
C     DBLSTR
C     JOB 0 = Ask initial questions
C     JOB 1 = Generate quality information
C     JOB 2 = Complement contig and region info.
C
      IF (JOB.EQ.0) THEN
      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
      ELSE IF (JOB.EQ.1) THEN
      CALL SUMMAN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +SEQ1,IDIM1,GEL,LSTRT,LEND,LLINO,PERCD,IDBSIZ,
     +TEMP3,ID1,CHRSIZ,MAXGL2,IDEVW,
     +MAXGEL,MXGOOD)
      IDIM1=LEND-LSTRT+1
      CALL SUMMER(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +SEQ2(LSTRT),IDIM1,GEL,LSTRT,LEND,LLINO,IDBSIZ,TEMP3,
     +CHRSIZ,MAXGL2,IDEVW,MAXGEL,IDM,PERCD)
      ELSE IF (JOB.EQ.2) THEN
C
C for complementary strand need to juggle the active region
C
         LSTRT = LREG-LSTRT
         LEND  = LREG-LEND
         IREG  = RREG
         RREG  = RELPG(LINCON) - LREG + 1
         LREG  = RELPG(LINCON) - IREG + 1
         LSTRT = LREG-LSTRT
         LEND  = LREG-LEND
         IF (LSTRT.LT.1) LSTRT=1
         IF (LEND.LT.1) LEND=1
C
         CALL CMPLMT(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +        LINCON,LNBR(LINCON),GEL,IDBSIZ,KBOUT,IDEVR,IDEVW,
     +        MAXGEL)
         LLINO = LNBR(LINCON)
         CALL SUMMAN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +        SEQ1,IDIM1,GEL,LSTRT,LEND,LLINO,PERCD,IDBSIZ,
     +        TEMP3,ID1,CHRSIZ,MAXGL2,IDEVW,
     +        MAXGEL,MXGOOD)
         CALL SUMMER(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +        SEQ2(LSTRT),IDIM1,GEL,LSTRT,LEND,LLINO,IDBSIZ,TEMP3,
     +        CHRSIZ,MAXGL2,IDEVW,MAXGEL,IDM,PERCD)
      END IF
      END
      SUBROUTINE SUMMAN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,
     +SEQ1,IDIM1,GEL,LREG,RREG,IGELC,PERCD,IDBSIZ,CHARS,
     +ID1,CHRSIZ,MAXGL2,IDEVW,MAXGEL,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
      INTEGER CHARS(CHRSIZ,ID1,MAXGL2)
      CHARACTER SYMS(7,7)
      EXTERNAL INDEXS,LWRAPS,IGTCON
      SAVE SYMS
      DATA SYMS/
     +'0','4','4','4','5','5','1',
     +'4','0','4','4','5','5','1',
     +'4','4','0','4','5','5','1',
     +'4','4','4','0','5','5','1',
     +'6','6','6','6','3','5','7',
     +'6','6','6','6','6','3','7',
     +'2','2','2','2','8','8','9'/
C
C codes are: using g = good consensus, b = bad consensus, n = no data
C
C               + -
C           0   g g =
C           1   g n
C           2   n g
C           3   b b
C           4   g g !=
C           5   g b
C           6   b g
C           7   b n
C           8   n b
C           9   n n      (should never occur!!!)
C
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)
        L1 = IGTCON(CHARS(1,1,JJJ),CHRSIZ,PERCD)
        L2 = IGTCON(CHARS(1,2,JJJ),CHRSIZ,PERCD)
        POSN1 = POSN1 + 1
        SEQ1(POSN1) = SYMS(L2,L1)
        DO 250 J=1,CHRSIZ
          CHARS(J,1,JJJ)=0
          CHARS(J,2,JJJ)=0
 250           CONTINUE
        POSN=POSN+1
 230       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
      INTEGER FUNCTION IGTCON(COUNTS,IDM,CUT)
      INTEGER IDM
      INTEGER COUNTS(IDM)
      CHARACTER CHARSU
      EXTERNAL CHARSU
C
C returns values 1 to 7: 7 means no data, 1-5 means a,c,g,t,*
C 6 means no consensus. if we change gtconc we should change this too
C
      IGTCON = 7
      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
          IGTCON = I
          RETURN
        END IF
 10         CONTINUE
      IGTCON = 6
      END
      SUBROUTINE CHKREV(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,NGELS,NCONTS,
     +IDEVN,IDEV,KBIN,KBOUT,DONEIT,MATES,IGELS,DIST,RNAMES)
      INTEGER RELPG(IDBSIZ),LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
      INTEGER DONEIT(IDBSIZ),MATES(IDBSIZ),IGELS(IDBSIZ),DIST(IDBSIZ)
      INTEGER GCLIN,DTOEND,CHAINL
      CHARACTER*(*) RNAMES(IDBSIZ)
      LOGICAL SAMEC
      EXTERNAL GCLIN,DTOEND,NMATE,SAMEC,CHAINL
      PARAMETER (MAXD = 99999)
C
C need to know which ones have already been mated
C
      CALL FILLI(DONEIT,NGELS,0)
      CALL FILLI(IGELS,NGELS,0)
      CALL FILLI(MATES,NGELS,0)
      CALL GNAMES(IDEVN,RNAMES,NGELS)
      IGEL = 0
      IDONE = 0
 10   CONTINUE
      IGEL = IGEL + 1
      IF (IGEL.EQ.NGELS) THEN
        IF (IDONE.GT.0) THEN
          CALL SHOWP(DIST,IGELS,MATES,IDONE,RNAMES,RELPG,IDBSIZ,IDEV)
        ELSE
          WRITE(KBOUT,*)'None found'
        END IF
        RETURN
      END IF
      IF (DONEIT(IGEL).EQ.1) GO TO 10
      MATE = NMATE(IGEL,NGELS,RNAMES,2)
      IF (MATE.EQ.0) GO TO 10
      DONEIT(MATE) = 1
      IDONE = IDONE + 1
C
C we have a pair igel and mate. deal separately with cases of 1 or 2 contigs
C
      IF (SAMEC(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,NGELS,NCONTS,IGEL,MATE))
     +  THEN
C
C same contig
C        
        IF (((LNGTHG(IGEL).GT.0).AND.(LNGTHG(MATE).GT.0)).OR.
     +  ((LNGTHG(IGEL).LT.0).AND.(LNGTHG(MATE).LT.0))) THEN
C
C >>>>>>>          >>>>>>>>> or <<<<<<<<      <<<<<<<<<<
C
          IGELS(IDONE) = IGEL
          MATES(IDONE) = MATE
          DIST(IDONE)  = MAXD
C          WRITE(KBOUT,*)IGEL,MATE,
C     +    ' are in the same contig face the same way'
          GO TO 10
        END IF
        IF (LNGTHG(IGEL).GT.0) THEN
          IF (RELPG(IGEL).GT.RELPG(MATE)+ABS(LNGTHG(MATE)) -1 ) THEN
C
C <<<<<<<222   111>>>>>>>>
C
            IGELS(IDONE) = IGEL
            MATES(IDONE) = MATE
            DIST(IDONE)  = MAXD
C            WRITE(KBOUT,*)IGEL,MATE,
C     +      ' are in the same contig and face away'
          ELSE
C
C 111>>>>> <<<<<<222
C
            IGELS(IDONE) = IGEL
            MATES(IDONE) = MATE
            DIST(IDONE)  = RELPG(MATE)+ABS(LNGTHG(MATE))-RELPG(IGEL)
C            WRITE(KBOUT,*)IGEL,RELPG(IGEL),MATE,RELPG(MATE)
          END IF
        ELSE
C
C <<<<<<111
C
          IF (RELPG(MATE).GT.RELPG(IGEL)+ABS(LNGTHG(IGEL)) -1 ) THEN
C
C <<<<<111 222>>>>>
C
            IGELS(IDONE) = IGEL
            MATES(IDONE) = MATE
            DIST(IDONE)  = MAXD
C            WRITE(KBOUT,*)IGEL,MATE,
C     +      ' are in the same contig and face away'
          ELSE
C
C >>>>>222  <<<<<111
C
            IGELS(IDONE) = IGEL
            MATES(IDONE) = MATE
            DIST(IDONE)  = RELPG(IGEL)+ABS(LNGTHG(IGEL))-RELPG(MATE)
C            WRITE(KBOUT,*)'same ',IGEL,RELPG(IGEL),MATE,RELPG(MATE)
          END IF
        END IF
      ELSE
C
C different contigs
C
        ICONTL = CHAINL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,IGEL)
        ICONT = GCLIN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,ICONTL)
        MCONTL = CHAINL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,MATE)
        MCONT = GCLIN(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,MCONTL)
        LENC1 = RELPG(ICONT)
        LENC2 = RELPG(MCONT)
        LENI = DTOEND(RELPG(IGEL),LNGTHG(IGEL),LENC1)
        LENM = DTOEND(RELPG(MATE),LNGTHG(MATE),LENC2)
        LENIM = LENI + LENM
        IGELS(IDONE) = -IGEL
        MATES(IDONE) = MATE
        DIST(IDONE)  = LENIM
C        WRITE(KBOUT,*)'different contigs',IGEL,MATE,' separation',LENIM
      END IF
      GO TO 10
      END
      SUBROUTINE SHOWP(DIST,IGELS,MATES,IDONE,RNAMES,RELPG,IDBSIZ,IDEV)
      INTEGER DIST(IDONE),IGELS(IDONE),MATES(IDONE),RELPG(IDBSIZ)
      CHARACTER*(*) RNAMES(IDBSIZ)
      CALL BUBBL3(DIST,IGELS,MATES,IDONE)
      DO 10 I=1,IDONE
        IF (IGELS(I).GT.0) THEN
          J = ABS(IGELS(I))
          WRITE(IDEV,1000)RNAMES(J),J,RELPG(J),DIST(I)
          J = MATES(I)
          WRITE(IDEV,1000)RNAMES(J),J,RELPG(J),DIST(I)
        END IF
 10   CONTINUE
      DO 20 I=1,IDONE
        IF (IGELS(I).LT.1) THEN
          J = ABS(IGELS(I))
          WRITE(IDEV,1000)RNAMES(J),J,RELPG(J),DIST(I),'*'
          J = MATES(I)
          WRITE(IDEV,1000)RNAMES(J),J,RELPG(J),DIST(I),'*'
        END IF
 20   CONTINUE
 1000 FORMAT(' ',A,3I6,A)
      END
      INTEGER FUNCTION DTOEND(RELPG,LNGTHG,LENCON)
      INTEGER RELPG
      IF (LNGTHG.GT.0) THEN
        DTOEND = LENCON - RELPG + 1
      ELSE
        DTOEND = RELPG + ABS(LNGTHG) - 1
      END IF
      END
      LOGICAL FUNCTION SAMEC(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,
     +NGELS,NCONTS,IGEL,JGEL)
      INTEGER RELPG(IDBSIZ),LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
      INTEGER CHAINL
      EXTERNAL CHAINL
      I = CHAINL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,IGEL)
      J = CHAINL(RELPG,LNGTHG,LNBR,RNBR,NGELS,NCONTS,IDBSIZ,JGEL)
      SAMEC = .FALSE.
      IF (I.EQ.J) SAMEC = .TRUE.
      END
      SUBROUTINE GNAMES(IDEVN,RNAMES,NGELS)
      CHARACTER*(*) RNAMES(NGELS)
      DO 10 I=1,NGELS
        CALL READN(IDEVN,I,RNAMES(I))
 10   CONTINUE
      END
      INTEGER FUNCTION  NMATE(IGEL,NGELS,RNAMES,JOB)
      PARAMETER (NAMLEN = 16)
      CHARACTER*(NAMLEN) NAME,NAMEM,RNAMES(NGELS)
C
C assume s1 and r1 are mates
C
C if job = 1 we look at all the names
C if job = 2 we look only at the ones with higher numbers
      NMATE = 0
      IF(JOB.EQ.1) THEN
        JGEL = 1
      ELSE IF(JOB.EQ.2) THEN
        JGEL = IGEL +1
      ELSE
        WRITE(*,*)'SCREAM: NMATE'
        RETURN
      END IF
      NAME = RNAMES(IGEL)
      I = INDEX(NAME,'.')
      IF (NAME(I+1:I+1).EQ.'s') THEN
        NAME(I+1:I+1) = 'r'
      ELSE
        NAME(I+1:I+1) = 's'
      END IF
      DO 10 I=JGEL,NGELS
        IF (I.NE.IGEL) THEN
          NAMEM = RNAMES(I)
          IF (NAME.EQ.NAMEM) THEN
            NMATE = I
            RETURN
          END IF
        END IF
 10   CONTINUE
      END
      SUBROUTINE LMATES(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,NGELS,
     +IDEV,IGELS,MATES,DIST,RNAMES,NMATES)
      INTEGER RELPG(IDBSIZ),LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
      INTEGER MATES(IDBSIZ),IGELS(IDBSIZ),DIST(IDBSIZ)
      CHARACTER*(*) RNAMES(IDBSIZ)
C
C list mates
C
C      WRITE(*,*)NMATES
      DO 10 I=1,NMATES
        J = IGELS(I)
        K = MATES(I)
        IF(DIST(I).GT.0) THEN
          WRITE(IDEV,1000)J,RNAMES(J),RELPG(J),LNGTHG(J),DIST(I)
          WRITE(IDEV,1000)K,RNAMES(K),RELPG(K),LNGTHG(K)
 1000     FORMAT(' ',I6,' ',A,' ',3I6)
        END IF
 10   CONTINUE
      DO 20 I=1,NMATES
        J = IGELS(I)
        K = MATES(I)
        IF(DIST(I).LT.0) THEN
          WRITE(IDEV,1000)J,RNAMES(J),RELPG(J),LNGTHG(J),DIST(I)
          WRITE(IDEV,1000)K,RNAMES(K),RELPG(K),LNGTHG(K)
        END IF
 20   CONTINUE
      END
      SUBROUTINE CHKREW(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,NGELS,
     +IDEVN,IGELS,MATES,DIST,RNAMES,LLINO,NMATES)
      INTEGER RELPG(IDBSIZ),LNGTHG(IDBSIZ),LNBR(IDBSIZ),RNBR(IDBSIZ)
      INTEGER MATES(IDBSIZ),IGELS(IDBSIZ),DIST(IDBSIZ)
      CHARACTER*(*) RNAMES(IDBSIZ)
      LOGICAL SAMEC
      EXTERNAL NMATE,SAMEC
C
C need to know which ones have already been mated
C
      CALL FILLI(IGELS,NGELS,0)
      CALL FILLI(MATES,NGELS,0)
      CALL GNAMES(IDEVN,RNAMES,NGELS)
      IGEL = LLINO
      NMATES = 0
 10   CONTINUE
      MATE = NMATE(IGEL,NGELS,RNAMES,1)
      IF (MATE.NE.0) THEN
        NMATES = NMATES + 1
        IGELS(NMATES) = IGEL
        MATES(NMATES) = MATE
C        WRITE(*,*)IGELS(NMATES),MATES(NMATES)
C
C we have a pair igel and mate. deal separately with cases of 1 or 2 contigs
C
        IF (SAMEC(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,NGELS,NCONTS,IGEL,MATE))
     +  THEN
C
C same contig
C        
          DIST(NMATES) = RELPG(MATE) + ABS(LNGTHG(MATE)) - RELPG(IGEL)
          IF(RELPG(MATE).LT.RELPG(IGEL)) THEN
C
C seen it before so skip it
C
            NMATES = NMATES - 1
C            IGELS(NMATES) = MATE
C            MATES(NMATES) = IGEL
          END IF
C          WRITE(*,*)IGELS(NMATES),MATES(NMATES)
C          WRITE(*,*)DIST(NMATES)
        ELSE
C
C different contigs
C
          DIST(NMATES) = -ABS(LNGTHG(IGELS(NMATES)))
C          WRITE(*,*)DIST(NMATES)
        END IF
      END IF
      IF (RNBR(IGEL).NE.0) THEN
        IGEL = RNBR(IGEL)
        GO TO 10
      END IF
      END
      SUBROUTINE GDEPTH(RELPG,LNGTHG,
     +IDBSIZ,LREG,RREG,IGELS,MATES,DIST,NMATES,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
C  AUTHOR: RODGER STADEN
      INTEGER RELPG(IDBSIZ),IGELS(NMATES),MATES(NMATES),DIST(NMATES)
      INTEGER LNGTHG(IDBSIZ)
      INTEGER RREG,DEPTH
C      WRITE(*,*)(IGELS(K),MATES(K),DIST(K),K=1,NMATES)
      CALL GDPTH(RELPG,
     +IDBSIZ,LREG,RREG,IGELS,MATES,DIST,NMATES,DEPTH)
      IF(NMATES.LT.1) RETURN
      CALL PLTCOG(RELPG,LNGTHG,IDBSIZ,IGELS,MATES,DIST,NMATES,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,LREG,RREG,DEPTH)
      END
      SUBROUTINE GDPTH(RELPG,
     +IDBSIZ,LREG,RREG,IGELS,MATES,DIST,NMATES,DEPTH)
C  AUTHOR: RODGER STADEN
      INTEGER RELPG(IDBSIZ),MATES(NMATES),IGELS(NMATES),DIST(NMATES)
      INTEGER RREG,DEPTH
      EXTERNAL NCDEPM
C  LREG = left contig position
C  RREG = right ''      ''
C
C have nmates reading numbers in igels and mates, their spacings are dist
C dist <0 means they are in different contigs
C the igels numbers are in left to right order
C
      I = 1
5     CONTINUE
      IF(I.LE.NMATES) THEN
        IF((RELPG(IGELS(I))+ABS(DIST(I))-1).LE.LREG) THEN
          I = I + 1
          GO TO 5
        END IF
      END IF
      DEPTH = 0
10    CONTINUE
      IF(I.LT.NMATES) THEN
        IF(RELPG(IGELS(I)).LE.RREG) THEN
            K = RELPG(IGELS(I)) + ABS(DIST(I))
            DEPTH = MAX(NCDEPM(RELPG,IDBSIZ,I,IGELS,NMATES,K),DEPTH)
          I = I + 1
          GO TO 10
        END IF
      END IF
C      WRITE(*,*)'DEPTH',DEPTH
      END
      SUBROUTINE PLTCOG(RELPG,LNGTHG,IDBSIZ,IGELS,MATES,DIST,NMATES,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,LREG,RREG,DEPTH)
      INTEGER DEPTH
      INTEGER RELPG(IDBSIZ),IGELS(NMATES),MATES(NMATES),DIST(NMATES)
      INTEGER LNGTHG(IDBSIZ)
      INTEGER RREG
C  have window size margt starting at margb
C  depths depthp, depthm
      CALL VECTOM
      CALL FRAME(MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      CALL PLTCG(RELPG,LNGTHG,
     +IDBSIZ,LREG,RREG,IGELS,MATES,DIST,NMATES,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,DEPTH)
      CALL VT100M
      END
      SUBROUTINE PLTCG(RELPG,LNGTHG,
     +IDBSIZ,LREG,RREG,IGELS,MATES,DIST,NMATES,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,DEPTH)
C  AUTHOR: RODGER STADEN
      INTEGER RELPG(IDBSIZ),IGELS(NMATES),MATES(NMATES),DIST(NMATES)
      INTEGER LNGTHG(IDBSIZ)
      INTEGER RREG,DEPTH
      CHARACTER SYM
      LOGICAL MATEY
      EXTERNAL MATEY
      YINC = REAL(ISYMAX) / (DEPTH + 1)
      XMIN = LREG
      XMAX = RREG
      YMAX = ISYMAX
      YMIN = 0.
      XSLOPE = REAL(MARGR - MARGL)/100.
      YSLOPE = YINC/10.
C      WRITE(*,*)XMIN,XMAX
      I = 1
5     CONTINUE
      IF(I.LE.NMATES) THEN
        IF((RELPG(IGELS(I))+ABS(DIST(I))-1).LT.LREG) THEN
          I = I + 1
          GO TO 5
        END IF
      END IF
      N = 0
10    CONTINUE
      IF(I.LE.NMATES) THEN
        IF(RELPG(IGELS(I)).LE.RREG) THEN
            XF = MAX(RELPG(IGELS(I)),LREG)
            XT = MIN(ABS(DIST(I))+RELPG(IGELS(I))-1,RREG)
            N = N + 1
            IF(N.GT.DEPTH) N = 1
            YF = N * YINC
C            WRITE(*,*)I,IGELS(I),MATES(I),DIST(I)
C            WRITE(*,*)RELPG(IGELS(I)),LNGTHG(IGELS(I))
C            WRITE(*,*)RELPG(MATES(I)),LNGTHG(MATES(I))
C            WRITE(*,*)I,XF,XT
            CALL LINE(XT,XF,YF,YF,XMAX,XMIN,YMAX,YMIN,
     +      MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
            IF (.NOT.(MATEY(IGELS(I),MATES(I),
     +      RELPG,LNGTHG,IDBSIZ)).AND.(DIST(I).GT.0)) THEN
              XF1 = XF + (XT-XF)/2.
              YT1 = YF - YSLOPE
              YT2 = YF + YSLOPE
              CALL LINE(XF1,XF1,YT1,YT2,XMAX,XMIN,YMAX,YMIN,
     +        MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
            END IF
            IF (LNGTHG(IGELS(I)).GT.0) THEN
              XT = RELPG(IGELS(I))+LNGTHG(IGELS(I))
              CALL RARROW(XT,YF,XSLOPE,YSLOPE,XMAX,XMIN,YMAX,YMIN,
     +        MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
            ELSE
              XT = MAX(RELPG(IGELS(I)),LREG)
              CALL LARROW(XT,YF,XSLOPE,YSLOPE,XMAX,XMIN,YMAX,YMIN,
     +        MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
            END IF
            IF (DIST(I).GT.0) THEN
              IF (LNGTHG(MATES(I)).GT.0) THEN
                XT = RELPG(MATES(I))+LNGTHG(MATES(I))
                CALL RARROW(XT,YF,XSLOPE,YSLOPE,XMAX,XMIN,YMAX,YMIN,
     +          MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
              ELSE
                XT = MIN(RELPG(MATES(I)),RREG)
                CALL LARROW(XT,YF,XSLOPE,YSLOPE,XMAX,XMIN,YMAX,YMIN,
     +          MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
              END IF
            ELSE
              SYM = '*'
              CALL TEXT(XT,YF,SYM,1,ISIZE,XMAX,XMIN,YMAX,YMIN,
     +        MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
            END IF
          I = I + 1
          GO TO 10
        END IF
      END IF
      END
      SUBROUTINE LARROW(XT,YF,XSLOPE,YSLOPE,XMAX,XMIN,YMAX,YMIN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      XF1 = XT + XSLOPE
      YT1 = YF + YSLOPE
      XF2 = XT + XSLOPE
      YT2 = YF - YSLOPE
      CALL LINE(XT,XF1,YF,YT1,XMAX,XMIN,YMAX,YMIN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      CALL LINE(XT,XF2,YF,YT2,XMAX,XMIN,YMAX,YMIN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      END
      SUBROUTINE RARROW(XT,YF,XSLOPE,YSLOPE,XMAX,XMIN,YMAX,YMIN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      XF1 = XT - XSLOPE
      YT1 = YF + YSLOPE
      XF2 = XT - XSLOPE
      YT2 = YF - YSLOPE
      CALL LINE(XT,XF1,YF,YT1,XMAX,XMIN,YMAX,YMIN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      CALL LINE(XT,XF2,YF,YT2,XMAX,XMIN,YMAX,YMIN,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX)
      END
      LOGICAL FUNCTION MATEY(IGEL,MATE,RELPG,LNGTHG,NGELS)
      INTEGER RELPG(NGELS),LNGTHG(NGELS)
      MATEY = .FALSE.
      IF (RELPG(IGEL).LT.RELPG(MATE)) THEN
        IF ((LNGTHG(IGEL).GT.0).AND.(LNGTHG(MATE).LT.0)) MATEY = .TRUE.
      ELSE
        IF ((LNGTHG(MATE).GT.0).AND.(LNGTHG(IGEL).LT.0)) MATEY = .TRUE.
      END IF
      END
      INTEGER FUNCTION NCDEPM(RELPG,IDBSIZ,IGEL,
     +IGELS,NMATES,RREG)
      INTEGER RELPG(IDBSIZ)
      INTEGER IGELS(NMATES)
      INTEGER RREG
      NCDEPM = 0
      N = 0
      I = IGEL
10    CONTINUE
      IF(I.LE.NMATES) THEN
        IF(RELPG(IGELS(I)).LE.RREG) THEN
          N = N + 1
          I = I + 1
          GO TO 10
        END IF
      END IF
      NCDEPM = N
      END
      SUBROUTINE XHGAP(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,NOPT4,
     +IHELPS,IHELPE,HELPF,IDEVH,MXGOOD,RNAMES,IGELS,MATES,DIST)
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*16,HELPF*(*)
      CHARACTER SEQ1(IDIM1),LINOU1(MAXGEL),LINOU2(MAXGEL)
      CHARACTER*(*) RNAMES(IDBSIZ)
      INTEGER MATES(IDBSIZ),IGELS(IDBSIZ),DIST(IDBSIZ),DEPTHR
      EXTERNAL NOPWIN,CWORLD,TUPPER,CHNRP1,HQN
C  nopt1 = single contig
C  nopt2 = all contigs
C  nopt3 = scan
C  nopt4 = plot templates with pairs of reads
      CALL CHKREW(RELPG,LNGTHG,LNBR,RNBR,IDBSIZ,NGELS,
     +IDEV3,IGELS,MATES,DIST,RNAMES,LLINOI,NMATES)
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)
C      WRITE(*,*)NOPT
      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)
C        WRITE(*,*)X,Y,IX,IY
        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 ',I6,' 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
      IF(NOPT.EQ.NOPT4) THEN
        CALL GDPTH(RELPG,
     +  IDBSIZ,LREG,RREG,IGELS,MATES,DIST,NMATES,DEPTHR)
C     +  MARGL,MARGR,MARGB(NOPT),MARGT(NOPT),ISXMAX,ISYMAX)
        IF(DEPTHR.LT.0) RETURN
        YMAX = ISYMAX
        YMIN = 0.
        XMIN = LREG
        XMAX = RREG
        X = CWORLD(IX,MARGL,MARGR,XMIN,XMAX)
        Y = CWORLD(IY,MARGB(NOPT),MARGT(NOPT),YMIN,YMAX)
C        WRITE(*,*)X,Y,IX,IY
        IF(TERM.EQ.'I') THEN
          CALL IPLTCG(RELPG,LNGTHG,
     +    IDBSIZ,LREG,RREG,IGELS,MATES,DIST,NMATES,
     +    MARGL,MARGR,MARGB(NOPT),MARGT(NOPT),ISXMAX,ISYMAX,DEPTHR,X,Y,
     +    IGEL,ICLOSE)
          IF(ICLOSE.EQ.1) GO TO 10
C          CALL READN(IDEV3,IGEL,NAMARC)
          J = IGELS(IGEL)
          WRITE(IDEV,1007)RNAMES(J),J,RELPG(J),LNGTHG(J)
          J = MATES(IGEL)
          WRITE(IDEV,1007)RNAMES(J),J,RELPG(J),LNGTHG(J)
 1007     FORMAT(' 'A,3I6)
C          WRITE(IDEV,1006)NAMARC,IGEL,RELPG(IGEL),LNGTHG(IGEL)
          GO TO 10
        END IF
      END IF
      END
      SUBROUTINE IPLTCG(RELPG,LNGTHG,
     +IDBSIZ,LREG,RREG,IGELS,MATES,DIST,NMATES,
     +MARGL,MARGR,MARGB,MARGT,ISXMAX,ISYMAX,DEPTH,X,Y,IGEL,IOK)
C  AUTHOR: RODGER STADEN
      INTEGER RELPG(IDBSIZ),IGELS(NMATES),MATES(NMATES),DIST(NMATES)
      INTEGER LNGTHG(IDBSIZ)
      INTEGER RREG,DEPTH
      LOGICAL MATEY
      EXTERNAL MATEY
      YINC = REAL(ISYMAX) / (DEPTH + 1)
      YINCO2 = YINC/2.
      XMIN = LREG
      XMAX = RREG
      YMAX = ISYMAX
      YMIN = 0.
C      WRITE(*,*)X,Y
C      WRITE(*,*)XMIN,XMAX,YMIN,YMAX,YINC
      I = 1
5     CONTINUE
      IF(I.LE.NMATES) THEN
        IF((RELPG(IGELS(I))+ABS(DIST(I))-1).LT.LREG) THEN
          I = I + 1
          GO TO 5
        END IF
      END IF
      N = 0
10    CONTINUE
      IF(I.LE.NMATES) THEN
        IF(RELPG(IGELS(I)).LE.RREG) THEN
            XF = MAX(RELPG(IGELS(I)),LREG)
            XT = MIN(ABS(DIST(I))+RELPG(IGELS(I))-1,RREG)
            N = N + 1
            IF(N.GT.DEPTH) N = 1
            YF = N * YINC
C            WRITE(*,*)XF,XT,YF
C            WRITE(*,*)I,IGELS(I),MATES(I),DIST(I)
C            WRITE(*,*)RELPG(IGELS(I)),LNGTHG(IGELS(I))
C            WRITE(*,*)RELPG(MATES(I)),LNGTHG(MATES(I))
C            WRITE(*,*)I,XF,XT
            IF((X.GE.XF).AND.(X.LE.XT)) THEN
              IF((Y.GE.YF-YINCO2).AND.(Y.LE.YF+YINCO2)) THEN
                IOK = 0
                IGEL = I
                RETURN
              END IF
            END IF
          I = I + 1
          GO TO 10
        END IF
      END IF
      IOK = 1
      END
