C     general subroutines
C     author rodger staden
C     14-2-90 changed titout to use gtstr (was using getstr)
C             and returned inflag to wrtact
C     16-3-90 replaced read in bpause by call to sin
C     18-4-90 added nmmtch for comparing strings (used by pir reading
C             routines to compare entry names)
C     4-7-90  added routines shofu, showfi,errom,busy
C     4-7-90  removed all routines dealing with sequence libraries
C             and put them into seqlibsubs.for
C     4-7-90  added radion, checkb
C     6-7-90  removed all routines related to userinterface
C    23-7-90  moved sethlp, help, help2 to userface
C             put hqn back for sap
C    10-12-90 Modified 2 lines in nmmtch to check for empty strings
C    24-4-91 Added new routines
C    18-11-91 moved openf1 from userface. deleted in userface and dialogues
C             also changed it to allow file deletion using delf
C    2-3-92 Altered ttext
C 10-4-92 made enco more efficient
      INTEGER FUNCTION HQN(STRING)
      CHARACTER STRING*(*),EM,QM
      PARAMETER (EM='!',QM='?')
      EXTERNAL NOTLR
C  AUTHOR: RODGER STADEN
C  RETURNS:
C          1 FOR HELP
C          2 FOR QUIT
C          3 FOR ALL BLANKS
C          0 OTHERWISE
      IF(STRING(1:1).EQ.QM) THEN
        HQN = 1
        RETURN
      END IF
      IF(STRING(1:1).EQ.EM) THEN
        HQN = 2
        RETURN
      END IF
      I = LEN(STRING)
      IN = NOTLR(STRING,I,' ')
      IF(IN.EQ.0) THEN
        HQN = 3
        RETURN
      END IF
      HQN = 0
      END
      SUBROUTINE RJST(STRING)
      CHARACTER STRING*(*)
      EXTERNAL NOTIRL
      L = LEN(STRING)
      I = NOTIRL(STRING,L,' ')
      IF(I.NE.L) THEN
        J = L
        DO 10 K = I,1,-1
          STRING(J:J) = STRING(K:K)
          J = J - 1
10      CONTINUE
C       MOVED DISTANCE L - I CHARS, SO FILL WITH SPACES
        I = L - I
        STRING(1:I) = ' '
      END IF
      END
      SUBROUTINE MARGC1(ISXMAX,ISYMAX,MARGL,MARGR,MARGB,MARGT,
     +HELPS,HELPE,HELPF,IDEVH,KBIN,KBOUT)
C   AUTHOR RODGER STADEN
      INTEGER HELPS,HELPE
      CHARACTER HELPF*(*)
      WRITE(KBOUT,8006)ISYMAX,MARGB,MARGT
8006  FORMAT(' y coordinates first:',/,
     +' screen height=',I6,' start position=',I5,
     +       ' height=',I5)
      IBOT = MARGB
      MNM = 1
      MXM = ISYMAX
      CALL GETINT(MNM,MXM,IBOT,'start height',
     +IVAL,KBIN,KBOUT,HELPS,HELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MARGB = IVAL
      ITOP = MIN(ISYMAX-MARGB,MARGT)
      MNM = MIN(ISYMAX/100,ITOP)
      MXM = ISYMAX-MARGB
      CALL GETINT(MNM,MXM,ITOP,'height',
     +IVAL,KBIN,KBOUT,HELPS,HELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MARGT = IVAL
      WRITE(KBOUT,8009)ISXMAX,MARGL,MARGR
8009  FORMAT(' x coordinates:',/,
     +' screen width=',I6,' start position=',I5,
     +       ' width=',I5)
      IBOT = MARGL
      MNM = 1
      MXM = ISXMAX
      CALL GETINT(MNM,MXM,IBOT,'start position',
     +IVAL,KBIN,KBOUT,HELPS,HELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MARGL = IVAL
      ITOP = MIN(ISXMAX-MARGL,MARGR)
      MNM = MIN(ISXMAX/100,ITOP)
      MXM = ISXMAX-MARGL
      CALL GETINT(MNM,MXM,ITOP,'width',
     +IVAL,KBIN,KBOUT,HELPS,HELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      MARGR = IVAL
      END
      INTEGER FUNCTION MC(SEQ1,SEQ2,LENGTH)
      CHARACTER SEQ1(LENGTH),SEQ2(LENGTH)
      EXTERNAL IUBM1
      MC = 1
      DO 10 I = 1,LENGTH
        IF(IUBM1(SEQ2(I),SEQ1(I)).EQ.0) RETURN
10    CONTINUE
      MC = 0
      END
      INTEGER FUNCTION GENRCI(STRING,LENS,LENI,C,LC,NENTRY)
      PARAMETER (LENM = 6)
      CHARACTER STRING(LENS)
      INTEGER REDS(17),REDE(17),RED(37),KS(LENM)
      INTEGER LS(LENM),II(LENM),C(0:LC)
      EXTERNAL NCODEA
      SAVE
C                 T,C,A,G,-       R   Y   W   S   M   K   H    B      V     D  
C
C              1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,
      DATA RED/1,2,3,4,1,2,3,4,3,4,1,2,1,3,2,4,2,3,1,4,1,2,3,1,
C              5,6,7,8,9,0,1,2,3,4,5,6,7
     +         2,4,2,3,4,1,3,4,1,2,3,4,5/
C                       -  R Y   W  S  M  K  H  B  V  D  N  ?
      DATA REDS/1,2,3,4,5, 9,11,13,15,17,19,21,24,27,30,33,37/
      DATA REDE/1,2,3,4,8,10,12,14,16,18,20,23,26,29,32,36,37/
      IENTRY = NENTRY
      NENTRY = 1
      IF(IENTRY.NE.0) GO TO 2
      CALL FILLI(KS,LENI,16)
      CALL CON17(STRING,KS,MIN(LENS,LENI))
      NEXT = 1
      II(1) = REDS(KS(1)) - 1
1     CONTINUE
      II(NEXT) = II(NEXT) + 1
      LS(NEXT) = RED(II(NEXT))
      IF(NEXT.LT.LENI) THEN
        NEXT = NEXT + 1
        II(NEXT) = REDS(KS(NEXT)) - 1
        GO TO 1
      END IF
C      WRITE(*,*)LS
      GENRCI = NCODEA(LS,LENI,C,5,LC)
      RETURN
2     CONTINUE
      DO 3 I = LENI,1,-1
        IF(II(I).LT.REDE(KS(I))) THEN
          NEXT = I
          GO TO 1
        END IF
3     CONTINUE
      GENRCI = 0
      END
      SUBROUTINE SETCN(C,LENGTH,IDM,LC)
      INTEGER C(0:LC)
      C(0) = 0
      K = IDM - 1
      N = 0
      DO 10 I = 1,LENGTH
        M = K**(I-1)
        C(0) = C(0) - C(N)
        DO 5 J = 1,K
          N = N + 1
          C(N) = J*M
5       CONTINUE
10    CONTINUE
      END
      INTEGER FUNCTION NCODEA(SEQ,LENGTH,C,IDM,LC)
      INTEGER SEQ(LENGTH),C(0:LC)
      NCODEA = 0
      N = C(0)
      J = 0
C  NEXT LINE NEW 4-7-89
      K = IDM - 1
      DO 10 I = 1,LENGTH
        L = SEQ(I)
        IF(L.EQ.IDM) RETURN
        N = N + C(J+L)
C  NEXT LINE NEW 4-7-89 (WAS J = J + 4)
        J = J + K
10    CONTINUE
      NCODEA = N
      END
      SUBROUTINE ENCOND(SEQ,IDIM,WORDP,IDE,IDCHAR,CONSTS,LENGTH,
     +LCONST)
C  AUTHOR RODGER STADEN
      INTEGER SEQ(IDIM),WORDP(IDE),CONSTS(0:LCONST)
      INTEGER NCODEA
      EXTERNAL NCODEA
C  ENCODES A SEQUENCE OF LENGTH IDIM AND CHARACTERSET SIZE IDCHAR
C  INTO TWO ARRAYS: WORDP(I) CONTAINS THE POSITION OF THE FIRST OCCURRENCE
C  OF WORD(I), SEQ(I) CONTAINS A LINKED LIST OF SECOND, THIRD,... OCCURENCES
C  OF WORD
      CALL FILLI(WORDP,IDE,0)
      DO 20 I = 1, IDIM-LENGTH+1
        J = NCODEA(SEQ(I),LENGTH,CONSTS,IDCHAR,LCONST)
        SEQ(I) = 0
        IF(J.NE.0) THEN
          J1 = WORDP(J)
          IF(J1.EQ.0) THEN
            WORDP(J) = I
          ELSE
10          CONTINUE
              J2 = J1
              J1 = SEQ(J2)
              IF(J1.NE.0) GO TO 10
              SEQ(J2) = I
          END IF
        END IF
20    CONTINUE
      END
      SUBROUTINE CON17(S,N,L)
      CHARACTER S(L)
      INTEGER N(L),DTONUM
      EXTERNAL DTONUM
      DO 1 I = 1,L
        N(I) = DTONUM(S(I))
1     CONTINUE
      END
      SUBROUTINE SEQEDT(SEQ,MAXSEQ,ISEQ,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IDEV,FILNAM,FILEIN,IDM,IOK)
      CHARACTER LINE*133,FILNAM*(*),FILEIN*(*),SEQ(MAXSEQ),HELPF*(*)
      CHARACTER CHARG1*14,CHARG2*48
      PARAMETER (CHARG1='TUCAG N-tucagn')
      PARAMETER 
     +(CHARG2='ABCDEFGHIKLMNPQRSTVWXYZabcdefghiklmnpqrstvwxyz- ')
      PARAMETER (NGOOD1 = 14, NGOOD2 = 48)
      EXTERNAL NOTRL
      IOK = 1
10    CONTINUE
      WRITE(KBOUT,1000)
1000  FORMAT(' Name of file to edit.')
      LIN = LEN(FILNAM)
      LIN = NOTRL(FILNAM,LIN,' ')
      CALL GTSTR('File name',FILNAM,FILEIN,LIN,KBOUT,KBIN,INFLAG)
      IF(INFLAG.EQ.1) THEN
        CALL HELP2(IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        GO TO 10
      END IF
      IF(INFLAG.EQ.2) RETURN
      IF(LIN.EQ.0) FILEIN = FILNAM
      CALL CEDIT(FILEIN)
      CALL YESNO(IWANT,'Make edited sequence active',
     +IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
      IOK = 1
      IF(IWANT.NE.0) RETURN
      CALL OPENRS(IDEV,FILEIN,IOK,LRECL,2)
      IF(IOK.NE.0) RETURN
      IF(IDM.EQ.5) THEN
        CALL FILTF(SEQ,MAXSEQ,ISEQ,LINE,IDEV,KBOUT,CHARG1,NGOOD1,IOK)
      ELSE IF(IDM.EQ.26) THEN
        CALL FILTF(SEQ,MAXSEQ,ISEQ,LINE,IDEV,KBOUT,CHARG2,NGOOD2,IOK)
      END IF
      CLOSE(UNIT=IDEV)
      END
      SUBROUTINE FILTF(SEQ,MAXSEQ,ISEQ,LINE,IDEV,KBOUT,CHARG,NGOOD,IOK)
      CHARACTER SEQ(MAXSEQ)
      CHARACTER LINE*(*),CHARG*(*)
      EXTERNAL LOK
      ISEQ = 0
      LNO = 0
      IOK = 1
10    CONTINUE
      LNO = LNO + 1
      READ(IDEV,1000,ERR=100,END=200)LINE
1000  FORMAT(A)
      IOK = LOK(LINE,CHARG,NGOOD)
      IF(IOK.EQ.0) THEN
        DO 5 I = 1,LEN(LINE)
          IF(LINE(I:I).NE.' ') THEN
            ISEQ = ISEQ + 1
            IF(ISEQ.GT.MAXSEQ) THEN
              WRITE(KBOUT,1001)MAXSEQ
1001          FORMAT(' Maximum sequence length',I6,' exceeded')
              RETURN
            END IF
            SEQ(ISEQ) = LINE(I:I)
          END IF
5       CONTINUE
      END IF
      GO TO 10
100   CONTINUE
      WRITE(KBOUT,1002)LNO
1002  FORMAT(' Error reading line',I6,' of file')
      RETURN
200   CONTINUE
      WRITE(KBOUT,1003)ISEQ
1003  FORMAT(' Sequence length is now',I6)
      IOK = 0
      END
      INTEGER FUNCTION LOK(LINE,OKC,NOKC)
      CHARACTER LINE*(*),OKC*(*)
      INTEGER COK
      EXTERNAL COK
      LOK = 1
      DO 10 I = 1,LEN(LINE)
        IF(COK(LINE(I:I),OKC,NOKC).NE.0) RETURN
10    CONTINUE
      LOK = 0
      END
      INTEGER FUNCTION COK(CHAR,OKC,NOKC)
      CHARACTER CHAR,OKC*(*)
      COK = 0
      DO 10 I = 1,NOKC
        IF(CHAR.EQ.OKC(I:I)) RETURN
10    CONTINUE
      COK = 1
      END
      INTEGER FUNCTION NOTILR(TEXT,ITEXT,WORD)
C   AUTHOR: RODGER STADEN
C   LOOKS LEFT TO RIGHT THRU TEXT FOR FIRST ELEMENT THAT IS NOT WORD
C   RETURNS ELEMENT NUMBER OR ZERO IF ALL ELEMENTS ARE WORD
      CHARACTER TEXT*(*),WORD
      NOTILR = 1
      DO 1 I=1,ITEXT
        NOTILR = I
        IF(TEXT(I:I).NE.WORD)RETURN
1     CONTINUE
      END
      INTEGER FUNCTION NOTIRL(TEXT,ITEXT,WORD)
C   AUTHOR: RODGER STADEN
C   LOOKS RIGHT TO LEFT THRU TEXT FOR FIRST ELEMENT THAT IS NOT WORD
C   RETURNS ELEMENT NUMBER OR ZERO IF ALL ELEMENTS ARE WORD
      CHARACTER TEXT*(*),WORD
      NOTIRL = ITEXT
      DO 1 I=ITEXT,1,-1
        NOTIRL = I
        IF(TEXT(I:I).NE.WORD)RETURN
1     CONTINUE
      END
      INTEGER FUNCTION NOTRLA(TEXT,ITEXT,WORD)
C   AUTHOR: RODGER STADEN
C   LOOKS RIGHT TO LEFT THRU TEXT FOR FIRST ELEMENT THAT IS NOT WORD
C   RETURNS ELEMENT NUMBER OR ZERO IF ALL ELEMENTS ARE WORD
      CHARACTER TEXT(ITEXT),WORD
      DO 1 I=ITEXT,1,-1
        NOTRLA = I
        IF(TEXT(I).NE.WORD)RETURN
1     CONTINUE
      NOTRLA = 0
      END
      INTEGER FUNCTION NOTLRA(TEXT,ITEXT,WORD)
C   AUTHOR: RODGER STADEN
C   LOOKS LEFT TO RIGHT THRU TEXT FOR FIRST ELEMENT THAT IS NOT WORD
C   RETURNS ELEMENT NUMBER OR ITEXT + 1 IF ALL ELEMENTS ARE WORD
      CHARACTER TEXT(ITEXT),WORD
      DO 1 I=1,ITEXT
        NOTLRA = I
        IF(TEXT(I).NE.WORD)RETURN
1     CONTINUE
      NOTLRA = ITEXT + 1
      END
      SUBROUTINE WRTACT(IDEV,FILNAM,KBIN,KBOUT,
     +SEQ,IDIM1,IHELPS,IHELPE,HELPF,IDEVH)
      CHARACTER SEQ(IDIM1),FILNAM*(*),HELPF*(*)
      CALL OPENF1(IDEV,FILNAM,1,IOK,KBIN,KBOUT,
     +'File name for active sequence',
     +IHELPS,IHELPE,HELPF,IDEVH)
      IF(IOK.EQ.0)THEN
        CALL TITOUT(IDEV,KBIN,KBOUT,
     +  IHELPS,IHELPE,HELPF,IDEVH,IOK)
        IF(IOK.NE.2)CALL FMTDK(IDEV,SEQ,IDIM1)
        CLOSE(UNIT=IDEV)
      END IF
      END
      SUBROUTINE GSPIN(MINSP,MAXSP,SPAN,MINIW,MAXIW,IWRIT,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
C   AUTHOR: RODGER STADEN
      CHARACTER HELPF*(*)
      INTEGER SPAN,VALUE
      IOK = 1
20    CONTINUE
      CALL GETINT(MINSP,MAXSP,SPAN,'odd span length',
     +VALUE,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0)RETURN
      IF(MOD(VALUE,2).EQ.0)GO TO 20
      SPAN = VALUE
      CALL GETINT(MINIW,MAXIW,IWRIT,'plot interval',
     +VALUE,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0)RETURN
      IWRIT = VALUE
      END
      SUBROUTINE GTSCR(STRING,IDIM,MATRIX,IDM,SMIN,SMAX)
C   AUTHOR RODGER STADEN
      INTEGER MATRIX(IDM,IDM),SMIN,SMAX
      CHARACTER STRING(IDIM)
      INTEGER DTONUM
      EXTERNAL DTONUM
      SMIN = 0
      SMAX = 0
      DO 10 I = 1,IDIM
        K1 = 99999
        K2 = -99999
        L = DTONUM(STRING(I))
        DO 5 J = 1,IDM
          M = MATRIX(L,J)
          K1 = MIN(K1,M)
          K2 = MAX(K2,M)
5       CONTINUE
        SMIN = SMIN + K1
        SMAX = SMAX + K2
10    CONTINUE
      END
      SUBROUTINE ADDR(FROM,TO,ID)
C   AUTHOR: RODGER STADEN
      REAL FROM(ID),TO(ID)
      DO 10 I = 1,ID
        TO(I) = TO(I) + FROM(I)
10    CONTINUE
      END
      SUBROUTINE ADDI(FROM,TO,ID)
C   AUTHOR: RODGER STADEN
      INTEGER FROM(ID),TO(ID)
      DO 10 I = 1,ID
        TO(I) = TO(I) + FROM(I)
10    CONTINUE
      END
      SUBROUTINE COPYR(FROM,TO,ID)
C   AUTHOR: RODGER STADEN
      REAL FROM(ID),TO(ID)
      DO 10 I = 1,ID
        TO(I) = FROM(I)
10    CONTINUE
      END
      SUBROUTINE GTREG(KBIN,KBOUT,J1,J2,I1,I2,P,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      CHARACTER HELPF*(*),P*(*)
C   AUTHOR: RODGER STADEN
      IOK = 1
      MININ = J1
      MAXIN = J2
      WRITE(KBOUT,1000)P
1000  FORMAT(' ',A)
      CALL GETINT(MININ,MAXIN,I1,'start',IVAL,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      IF(IVAL.NE.I1) THEN
        I2 = J2
      END IF
      I1 = IVAL
      IF(I1.EQ.0) RETURN
      MININ = I1 + 1
      MAXIN = J2
      CALL GETINT(MININ,MAXIN,I2,'end',IVAL,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IOK)
      IF(IOK.NE.0) RETURN
      I2 = IVAL
      IOK = 0
      END
      SUBROUTINE CCASEA(STRING,L,IFLAG)
      CHARACTER STRING(L),TUPPER,TLOWER
      EXTERNAL TUPPER,TLOWER
C   AUTHOR RODGER STADEN
      IF(IFLAG.EQ.1)THEN
        DO 10 I = 1,L
          STRING(I) = TUPPER(STRING(I))
10      CONTINUE
      ELSE IF(IFLAG.EQ.2)THEN
        DO 20 I = 1,L
          STRING(I) = TLOWER(STRING(I))
20      CONTINUE
      END IF
      END
      INTEGER FUNCTION INDEXA(STRING,ID,CHAR)
      CHARACTER STRING(ID),CHAR
C  FUNCTION TO FIND FIRST OCCURRENCE OF CHAR IN STRING
      DO 10 I = 1,ID
        IF(STRING(I).EQ.CHAR)THEN
          INDEXA = I
          RETURN
        END IF
10    CONTINUE
      INDEXA = 0
      END
      SUBROUTINE TITOUT(IDEV,KBIN,KBOUT,IHELPS,IHELPE,HELPF,
     +IDEVH,INFLAG)
C   AUTHOR: RODGER STADEN
      CHARACTER LINE*60,HELPF*(*)
10    CONTINUE
      WRITE(KBOUT,1000)
1000  FORMAT(' You may give your sequence a one line title.')
      LIN = 0
      CALL GTSTR('Title',' ',LINE,LIN,KBOUT,KBIN,INFLAG)
      IF(LIN.LT.1) RETURN
      IF(INFLAG.EQ.1) THEN
        CALL HELP2(IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        GO TO 10
      END IF
      IF(INFLAG.EQ.2) RETURN
        WRITE(IDEV,1004,ERR=20)LINE(1:LIN)
1004    FORMAT(';',A)
20    CONTINUE
      END     
      SUBROUTINE TTEXT(IDEV,FILNAM,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH)
C   AUTHOR: RODGER STADEN
      CHARACTER FILNAM*(*),HELPF*(*)
      CALL OPENF1(IDEV,FILNAM,0,IOK,KBIN,KBOUT,
     +'Name of file to read',
     +IHELPS,IHELPE,HELPF,IDEVH)
      IF(IOK.NE.0) RETURN
      CALL TTEXT1(IDEV,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IQUIT)
      END
      SUBROUTINE TTEXT1(IDEV,KBIN,KBOUT,
     +IHELPS,IHELPE,HELPF,IDEVH,IQUIT)
C   AUTHOR: RODGER STADEN
      PARAMETER (IPAGE=22)
      CHARACTER LINE*80,HELPF*(*),SPACE
      INTEGER NOTIRL
      EXTERNAL NOTIRL
      SAVE SPACE
      DATA SPACE/' '/
1002  FORMAT(' ',A)
C   COUNT LINES OUTPUT
      LINDON=0
      IDONE=0
10    CONTINUE
        READ(IDEV,1003,ERR=110,END=30)LINE
1003    FORMAT(A)
        WRITE(KBOUT,1002)LINE(1:MAX(1,NOTIRL(LINE,79,SPACE)))
        IDONE=IDONE+1
        LINDON=LINDON+1
        IF(IDONE.GE.IPAGE)THEN
          CALL BPAUSE(KBIN,KBOUT,IQUIT)
          IF(IQUIT.NE.0) GO TO 50
          IDONE=0
        END IF
      GO TO 10
30    CONTINUE
      WRITE(KBOUT,1005)
1005  FORMAT(' End of file')
      CALL BPAUSE(KBIN,KBOUT,IQUIT)
50    CONTINUE
      CLOSE(UNIT=IDEV)
      RETURN
110   CONTINUE
      WRITE(KBOUT,1010)
1010  FORMAT(' Error reading file')
      CLOSE(UNIT=IDEV)
      END
      SUBROUTINE CCASE(STRING,IFLAG)
      CHARACTER STRING*(*),TUPPER,TLOWER
      EXTERNAL TUPPER,TLOWER
C   AUTHOR RODGER STADEN
      L = LEN(STRING)
      IF(IFLAG.EQ.1)THEN
        DO 10 I = 1,L
          STRING(I:I) = TUPPER(STRING(I:I))
10      CONTINUE
      ELSE IF(IFLAG.EQ.2)THEN
        DO 20 I = 1,L
          STRING(I:I) = TLOWER(STRING(I:I))
20      CONTINUE
      END IF
      END
      CHARACTER*1 FUNCTION TUPPER(CHAR1)
C   AUTHOR RODGER STADEN
      CHARACTER UP*26,LOW*26,CHAR1
      SAVE LOW,UP
      DATA UP/ 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' /
      DATA LOW/ 'abcdefghijklmnopqrstuvwxyz' /
      I = INDEX(LOW,CHAR1)
      TUPPER = CHAR1
      IF (I.NE.0) TUPPER = UP(I:I)
      END
      CHARACTER*1 FUNCTION TLOWER(CHAR1)
C   AUTHOR RODGER STADEN
      CHARACTER UP*26,LOW*26,CHAR1
      SAVE LOW,UP
      DATA UP/ 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' /
      DATA LOW/ 'abcdefghijklmnopqrstuvwxyz' /
      I = INDEX(UP,CHAR1)
      TLOWER = CHAR1
      IF (I.NE.0) TLOWER = LOW(I:I)
      END
      INTEGER FUNCTION NOTLR(TEXT,ITEXT,WORD)
C   AUTHOR: RODGER STADEN
C   LOOKS LEFT TO RIGHT THRU TEXT FOR FIRST ELEMENT THAT IS NOT WORD
C   RETURNS ELEMENT NUMBER OR ZERO IF ALL ELEMENTS ARE WORD
      CHARACTER TEXT*(*),WORD
      DO 1 I=1,ITEXT
        IF(TEXT(I:I).NE.WORD)THEN
          NOTLR = I
          RETURN
        END IF
1     CONTINUE
      NOTLR = 0
      END
      INTEGER FUNCTION NOTRL(TEXT,ITEXT,WORD)
C   AUTHOR: RODGER STADEN
C   LOOKS RIGHT TO LEFT THRU TEXT FOR FIRST ELEMENT THAT IS NOT WORD
C   RETURNS ELEMENT NUMBER OR ZERO IF ALL ELEMENTS ARE WORD
      CHARACTER TEXT*(*),WORD
      DO 1 I=ITEXT,1,-1
        IF(TEXT(I:I).NE.WORD)THEN
          NOTRL=I
          RETURN
        END IF
1     CONTINUE
      NOTRL = 0 
      END
      CHARACTER*3 FUNCTION TRANF3(CODON,PAA,CODE)
C   AUTHOR RODGER STADEN
      CHARACTER CODON(3),PAA(5,5,5),THREEL*3,TRANF,THREE*3
      INTEGER CODE
      EXTERNAL THREEL,TRANF
      THREE(1:3)='   '
      IF(CODE.EQ.3)THEN
        THREE(1:3)=THREEL(TRANF(CODON,PAA))
      ELSE
        THREE(2:2)=TRANF(CODON,PAA)
      END IF
      TRANF3=THREE
      RETURN
      END
C   TRANB3
      CHARACTER*3 FUNCTION TRANB3(CODON,PAA,CODE)
C   AUTHOR RODGER STADEN
      CHARACTER CODON(3),PAA(5,5,5),THREEL*3,TRANB,THREE*3
      INTEGER CODE
      EXTERNAL THREEL,TRANB
      THREE='   '
      IF(CODE.EQ.3)THEN
        THREE(1:3)=THREEL(TRANB(CODON,PAA))
      ELSE
        THREE(2:2)=TRANB(CODON,PAA)
      END IF
      TRANB3=THREE(1:3)
      RETURN
      END
C   TRANF
      CHARACTER*1 FUNCTION TRANF(CODON,PAA)
C   AUTHOR: RODGER STADEN
      CHARACTER CODON(3),PAA(5,5,5)
      INTEGER IC(3),CTONUM
      EXTERNAL CTONUM
C
      DO 10 I=1,3
      IC(I)=CTONUM(CODON(I))
10    CONTINUE
      TRANF=PAA(IC(3),IC(2),IC(1))
      RETURN
      END
C   TRANB
      CHARACTER*1 FUNCTION TRANB(CODON,PAA)
C   AUTHOR: RODGER STADEN
      CHARACTER*1 CODON(3),PAA(5,5,5)
      INTEGER IC(3),CTONUM,ICOMP
      EXTERNAL CTONUM,ICOMP
C
      DO 10 I=1,3
      IC(I)=CTONUM(CODON(I))
10    CONTINUE
      TRANB=PAA(ICOMP(IC(1)),ICOMP(IC(2)),ICOMP(IC(3)))
      RETURN
      END
C   THREEL
      CHARACTER*3 FUNCTION THREEL(ONEL)
      CHARACTER ONEL,ALLONE*21
      CHARACTER*3 THREES(21)
      SAVE ALLONE,THREES
      DATA ALLONE/'ACDEFGHIKLMNPQRSTVWY*'/
      DATA THREES/
     +'Ala','Cys','Asp','Glu','Phe','Gly','His','Ile','Lys',
     +'Leu','Met','Asn','Pro','Gln','Arg','Ser','Thr','Val',
     +'Trp','Tyr','***'/
      THREEL='   '
      DO 10 I=1,21
        IF(ONEL.EQ.ALLONE(I:I))THEN
          THREEL=THREES(I)(1:3)
          RETURN
        END IF
10    CONTINUE
      RETURN
      END
      SUBROUTINE MWCALC(SEQ,IDIM,J1,J2,KBOUT,IDEV)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM),CHRSET(26)
      REAL AAWTS(26),AWTSUM(26),ASUM(26)
      INTEGER CTONUM
      EXTERNAL CTONUM 
      SAVE CHRSET,AAWTS
      DATA CHRSET/
     +'C','S','T','P','A','G','N',
     +'D','E','Q','B','Z','H','R',
     +'K','M','I','L','V','F','Y',
     +'W','-','X','?',' '/
C VALUES CHANGED 26-2-91
      DATA AAWTS/103.1388,87.0782,101.1051,97.1167,71.0788,57.0519,
     +           114.1038,
     +           115.0886,129.1155,128.1307,0.0,0.0,137.1411,156.1875,
     +           128.1714,131.1926,113.1594,113.1594,99.1326,147.1766,
     +           163.1760,
     +           186.2132,0.0,0.0,0.0,0.0/
C      DATA AAWTS/103.15,87.09,101.12,97.13,71.09,57.07,114.12,
C     +           115.10,129.13,128.15,0.0,0.0,137.16,156.21,
C     +           128.19,131.22,113.18,113.18,99.15,147.19,163.19,
C     +           186.22,0.0,0.0,0.0,0.0/
      WRITE(KBOUT,*)' Sequence composition'
      REALN = J2 - J1 + 1
      REALN = 100.0/REALN
      SUMWT=0.
C      SUMPOL=0.
      DO 20 I=1,26
         ASUM(I)=0.
         AWTSUM(I)=0.
20    CONTINUE
      DO 30 I=J1,J2
         IACID=CTONUM(SEQ(I))
         ASUM(IACID)=ASUM(IACID)+1.
         AWTSUM(IACID)=AWTSUM(IACID)+AAWTS(IACID)
C         AWTSUM(IACID)=AWTSUM(IACID)+AAWTS(IACID)-0.015
C         SUMPOL=SUMPOL+POLAR(IACID)
C         SUMWT=SUMWT+AAWTS(IACID)-0.015
         SUMWT=SUMWT+AAWTS(IACID)
30    CONTINUE
C   ADD ON 1 WATER MOLECULE
      SUMWT=SUMWT+18.0152
      WRITE(IDEV,1000)(CHRSET(K),K=1,13)
      WRITE(IDEV,1001)(ASUM(K),K=1,13)
      WRITE(IDEV,1004)(REALN*ASUM(K),K=1,13)
      WRITE(IDEV,1002)(AWTSUM(K),K=1,13)
      WRITE(IDEV,1000)(CHRSET(K),K=14,26)
      WRITE(IDEV,1001)(ASUM(K),K=14,26)
      WRITE(IDEV,1004)(REALN*ASUM(K),K=14,26)
      WRITE(IDEV,1002)(AWTSUM(K),K=14,26)
1000  FORMAT(/' A',13(3X,1A,2X))
1001  FORMAT(' N',13(1X,F4.0,1X))
1002  FORMAT(' W',13F6.0)
1004  FORMAT(' %',13F6.1)
      WRITE(IDEV,1003)SUMWT
1003  FORMAT(' Total molecular weight=',F12.3)
      RETURN
      END
C
      SUBROUTINE BCOMP(SEQ,IDIM,J1,J2,KSTART,IDEV)
C   AUTHOR RODGER STADEN
      CHARACTER SEQ(IDIM)
      REAL TOT(5)
      INTEGER CTONUM
      EXTERNAL CTONUM
      WRITE(IDEV,*)' Sequence composition'
      DO 10 I=1,5
       TOT(I)=0.0
10    CONTINUE
      DO 20 I=J1-KSTART+1,J2-KSTART+1
       J=CTONUM(SEQ(I))
       TOT(J)=TOT(J)+1.
20    CONTINUE
      WRITE(IDEV,1000)
1000  FORMAT(' ',10X,'T',10X,'C',10X,'A',10X,'G',10X,'-')
      WRITE(IDEV,1001)TOT
1001  FORMAT(' ',1X,5(F10.0,1X))
      T=100.0/(J2-J1+1)
      WRITE(IDEV,1002)(TOT(K)*T,K=1,5)
1002  FORMAT(' ',2X,5(F10.1,'%'))
      RETURN
      END
C   SUBROUTINE TO READ CHARACTER DATA FROM IDEV, REMOVE SPACES, FILL
C   ARRAY AND RETURN NUMBER OF ELEMENTS USED. ANY LINES STARTING WITH
C   A ; ARE TREATED AS COMMENTS AND WRITTEN TO DEVICE KBOUT
      SUBROUTINE ARRFIL(IDEV,SEQNCE,J,KBOUT)
C 14-8-91 Added err= option to read, and set length to 0 if error found
C   AUTHOR: RODGER STADEN
      CHARACTER TEMP(80),SEQNCE(J)
      CHARACTER SPACE,ENDCHR,TITCHR
      SAVE ENDCHR,SPACE,TITCHR
      DATA ENDCHR/'@'/
      DATA SPACE/' '/
      DATA TITCHR/';'/
      IDMX=J
      J=0
1     CONTINUE
      READ(IDEV,1001,END=30,ERR=40)TEMP
1001  FORMAT(80A1)
      IF(TEMP(1).EQ.TITCHR)THEN
        WRITE(KBOUT,1003)(TEMP(K),K=2,80)
1003    FORMAT(' ',79A1)
        GO TO 1
      END IF
10    CONTINUE
      DO 20 I=1,80
        IF(TEMP(I).NE.SPACE)THEN
          IF(TEMP(I).EQ.ENDCHR)RETURN
          IF(J.EQ.IDMX)THEN
            WRITE(KBOUT,1002)IDMX
1002        FORMAT(
     +             ' Too much data. Maximum possible',
     +             ' =',I6,', input stopped there')
            RETURN
          END IF
          J=J+1
          SEQNCE(J)=TEMP(I)
        END IF
20    CONTINUE
      GO TO 1
30    CONTINUE
      RETURN
 40   CONTINUE
      CALL ERROM(KBOUT,'Error reading file')
      J = 0
      END
C     BUB2AS
C   SUBROUTINE TO SORT INTEGER ARRAY (LIST) INTO ASCENDING  ORDER
      SUBROUTINE BUB2AS(LIST,LIST2,IDIM)
C   AUTHOR: RODGER STADEN
      INTEGER LIST(IDIM),LIST2(IDIM)
      I=0
      J=0
10    CONTINUE
C   SET I=J IF WE HAVE JUST CORRECTLY POSITIONED AN ELEMENT
      IF(J.GT.I)I=J
      I=I+1
      IF(I.EQ.IDIM)RETURN
20    CONTINUE
      IF(LIST(I).LE.LIST(I+1))GO TO 10
C   FIRST MOVE THIS ELEMENT? IF SO SET POINTER TO ITS INITIAL POSITION
      IF(J.LT.I)J=I
      ITEMP=LIST(I)
      LIST(I)=LIST(I+1)
      LIST(I+1)=ITEMP
      ITEMP=LIST2(I)
      LIST2(I)=LIST2(I+1)
      LIST2(I+1)=ITEMP
C   DECREMENT BACK THRU LIST WITH THIS ELEMENT
      IF(I.GT.1)I=I-1
      GO TO 20
      END
      SUBROUTINE BUB3AS(LIST,LIST2,LIST3,IDIM)
C   AUTHOR: RODGER STADEN
      INTEGER LIST(IDIM),LIST2(IDIM),LIST3(IDIM)
      I=0
      J=0
10    CONTINUE
C   SET I=J IF WE HAVE JUST CORRECTLY POSITIONED AN ELEMENT
      IF(J.GT.I)I=J
      I=I+1
      IF(I.EQ.IDIM)RETURN
20    CONTINUE
      IF(LIST(I).LE.LIST(I+1))GO TO 10
C   FIRST MOVE THIS ELEMENT? IF SO SET POINTER TO ITS INITIAL POSITION
      IF(J.LT.I)J=I
      ITEMP=LIST(I)
      LIST(I)=LIST(I+1)
      LIST(I+1)=ITEMP
      ITEMP=LIST2(I)
      LIST2(I)=LIST2(I+1)
      LIST2(I+1)=ITEMP
      ITEMP=LIST3(I)
      LIST3(I)=LIST3(I+1)
      LIST3(I+1)=ITEMP
C   DECREMENT BACK THRU LIST WITH THIS ELEMENT
      IF(I.GT.1)I=I-1
      GO TO 20
      END
C     CHARCT
C   SUBROUTINE TO COUNT NUMBRE OF CHARS BETWSEN ENCLOSING /S
      SUBROUTINE CHARCT(CHARS,IDIM,PCHAR,NCHAR)
C   AUTHOR: RODGER STADEN
      CHARACTER CHARS(IDIM),SLASH
      INTEGER PCHAR
      SAVE SLASH
      DATA SLASH/'/'/
      NCHAR=-1
C
10    CONTINUE
      NCHAR=NCHAR+1
      I=NCHAR+PCHAR
      IF(I.EQ.IDIM)RETURN
      IF(CHARS(I).EQ.SLASH)RETURN
      GO TO 10
      END
C     encona
C   routine to store positions of words in posns and first occurences
C   in wordp and number of occurences in wordn
C   each number is a value representing one of the le4 possible
C   words of length length made up of 4 characters
C   words in posns are numbers from 1 to 4**length
      SUBROUTINE ENCONA(POSNS,IDIM,WORDP,WORDN,LE4,LENGTH)
C   AUTHOR: RODGER STADEN
      INTEGER WORDP(LE4),POSNS(IDIM)
      INTEGER WORDN(LE4)
C   number of words of length length
      IDIM1 = IDIM - (LENGTH-1)
      DO 10 I=1,LE4
        WORDN(I) = 0
10    CONTINUE
C   loop for each word
      DO 100 I=1,IDIM1
        N = POSNS(I)
        IF(N.EQ.0)GO TO 100
C   is their already an entry for this word?
        IF(WORDN(N).NE.0)GO TO 60
C  first entry, put in wordp
        WORDP(N)=I
        GO TO 80
60    CONTINUE
C   need to chain along posn until find correct posn for i
C   first posn is in wordp(n)
      IP=WORDP(N)
      DO 70 J=2,WORDN(N)
70    IP=POSNS(IP)
C   so put this i at posns(ip)
      POSNS(IP)=I
80    CONTINUE
C   now increment number of occurences of n
      WORDN(N)=WORDN(N)+1
100   CONTINUE
      RETURN
      END
C   routine to turn a sequence of 1,2,3,4,0 to numbers
C   each number is a value representing one of the 4**length
C   possible words of length length made up of 4 characters
      SUBROUTINE ENCO(SEQ,IDIM,POSNS,CONST,LENGTH)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM)
      INTEGER POSNS(IDIM),CONST(LENGTH)
      INTEGER CTONUM
      EXTERNAL CTONUM
      ISTART = 1
      DO 1 I=1,LENGTH
        CONST(I) = 4**(I-1)
        ISTART = ISTART - CONST(I)
 1    CONTINUE
C   how many words of length length
      IDIM1 = IDIM - (LENGTH-1)
      DO 3 I=1,IDIM
        POSNS(I) = 0
 3    CONTINUE
C   loop for each word
      DO 100 I=1,IDIM1
        IP = I
        N = ISTART
        DO 30 J=1,LENGTH
          IC = CTONUM(SEQ(IP))
          IF (IC.EQ.5) GO TO 100
          N = N + CONST(J) * IC
          IP = IP + 1
30      CONTINUE
        POSNS(I) = N
100   CONTINUE
      END
      INTEGER FUNCTION IFROMC(CHARS,LENGTH,KBOUT)
C   AUTHOR: RODGER STADEN
C   INTEGER FUNCTION TO CONVERT CHARACTER STRINGS OF
C   NUMERALS TO BINARY FORM
      CHARACTER NUMBER*10,CHARS(LENGTH)
C   LENGTH OF STRING NUMBER
      LENS=10
      NUMBER=' '
      CALL RJSTFY(CHARS,NUMBER,LENS,LENGTH)
      READ(NUMBER,1002,ERR=100)LIST
1002  FORMAT(I10)
      IFROMC=LIST
      RETURN
100   CONTINUE
      WRITE(KBOUT,1006)
1006  FORMAT(' Error in internal read, value set to zero')
      IFROMC=0
      RETURN
      END
      SUBROUTINE RJSTFY(ARRAY,STRING,LENS,LENGTH)
C   AUTHOR: RODGER STADEN
      CHARACTER STRING*(*),ARRAY(LENGTH)
      STRING=' '
C   LOOK FOR FIRST NON SPACE CHAR
      K=LENGTH+1
      DO 1 I=1,LENGTH
      K=K-1
1     IF(ARRAY(K).NE.' ')GO TO 2
C   ALL SPACES!
      RETURN
2     CONTINUE
      K1=K
C  POINT TO RIGHT END OF STRING
      K3=LENS+1
      DO 3 I=1,K1
      K3=K3-1
      STRING(K3:K3)=ARRAY(K)
3     K=K-1
      RETURN
      END
      SUBROUTINE OPENF(IDEV,FILNAM,IWRITE,IOK,KBIN,KBOUT)
C   AUTHOR: RODGER STADEN
      CHARACTER FILNAM*(*)
      IOK=1
10    CONTINUE
      READ(KBIN,1000,ERR=300,END=300)FILNAM
1000  FORMAT(A)
C   WANT TO WRITE?
      IF(IWRITE.NE.0)GO TO 200
C   READONLY
      CALL OPENRS(IDEV,FILNAM,IOK,LRECL,2)
      RETURN
C   WRITE
200   CONTINUE
      CALL OPENRS(IDEV,FILNAM,IOK,LRECL,1)
300   CONTINUE
      RETURN
      END
C     SQCOM
      SUBROUTINE SQCOM(SEQ,IDIM)
C   AUTHOR: RODGER STADEN
      PARAMETER (MAXLST = 38)
      CHARACTER SEQ(IDIM),LIST1(MAXLST),LIST2(MAXLST),TEMP
      SAVE LIST1,LIST2
      DATA LIST1/
     +'C','T','A','G',
     +'c','t','a','g',
     +'D','V','B','H',
     +'d','v','b','h',
     +'K','L','M','N',
     +'k','l','m','n',
     +'R','Y','U',
     +'r','y','u',
     +'1','2','3','4',
     +'5','6','7','8'/
      DATA LIST2/
     +'G','A','T','C',
     +'g','a','t','c',
     +'H','B','V','D',
     +'h','b','v','d',
     +'N','M','L','K',
     +'n','m','l','k',
     +'Y','R','A',
     +'y','r','a',
     +'4','3','2','1',
     +'6','5','7','8'/
      DO 100 I=1,IDIM
        TEMP = SEQ(I)
        DO 50 J=1,MAXLST
          IF(TEMP.EQ.LIST1(J))THEN
            SEQ(I)=LIST2(J)
            GO TO 99
          END IF
50      CONTINUE
99      CONTINUE
100   CONTINUE
      END
C     SQCOPY
C   SEQUENCE COPYING PROGRAM
      SUBROUTINE SQCOPY(SEQNCE,COMSEQ,IDIM)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQNCE(IDIM),COMSEQ(IDIM)
      DO 100 I=1,IDIM
        COMSEQ(I)=SEQNCE(I)
100   CONTINUE
      RETURN
      END
C   SQREV
      SUBROUTINE SQREV(SEQNCE,IDIM)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQNCE(IDIM),TEMP
C   REVERSE THE SEQUENCE
      IEND=IDIM/2
      DO 100 I=1,IEND
      TEMP=SEQNCE(I)
        SEQNCE(I)=SEQNCE(IDIM+1-I)
        SEQNCE(IDIM+1-I)=TEMP
100   CONTINUE
      RETURN
      END
C   DNARNA OR RNADNA
      SUBROUTINE DNARNA(SEQ,IDSEQ)
C   AUTHOR RODGER STADEN
      CHARACTER SEQ(IDSEQ),TEMP,TCHAR,UCHAR,LTCHAR,LUCHAR
      SAVE TCHAR,UCHAR,LTCHAR,LUCHAR
      DATA TCHAR/'T'/,UCHAR/'U'/,LTCHAR/'t'/,LUCHAR/'u'/
      DO 10 I=1,IDSEQ
        TEMP = SEQ(I)
        IF(TEMP.EQ.TCHAR)THEN
          SEQ(I)=UCHAR
        ELSE IF(TEMP.EQ.LTCHAR)THEN
          SEQ(I)=LUCHAR
        ELSE IF(TEMP.EQ.UCHAR)THEN
          SEQ(I)=TCHAR
        ELSE IF(TEMP.EQ.LUCHAR)THEN
          SEQ(I)=LTCHAR
        END IF
10    CONTINUE
      END
      SUBROUTINE FMTDKN(IDEV,SEQNCE,IDIM)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQNCE(IDIM)
C   SET POINTERS TO FIRST AND LAST ELEMENTS ONE WRITE
      JS=1
      JE=60
10    CONTINUE
C   SET JE TO LAST ELEMENT IF NECESSARY
      IF(JE.GT.IDIM)JE=IDIM
      WRITE(IDEV,1002)(SEQNCE(I),I=JS,JE)
1002  FORMAT(' ',60A1)
C   TEST FOR END
      IF(JE.NE.IDIM) THEN
        JS=JE+1
        JE=JE+60
        GO TO 10
      END IF
      END
      SUBROUTINE FMTDK(IDEV,SEQNCE,IDIM)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQNCE(IDIM)
C   SET POINTERS TO FIRST AND LAST ELEMENTS ONE WRITE
      JS=1
      JE=60
10    CONTINUE
C   SET JE TO LAST ELEMENT IF NECESSARY
      IF(JE.GT.IDIM)JE=IDIM
      WRITE(IDEV,1002)(SEQNCE(I),I=JS,JE)
1002  FORMAT(' ',60A1)
C   TEST FOR END
      IF(JE.EQ.IDIM)GO TO 20
C   INCREMENT FIRST AND LAST POINTERS
      JS=JE+1
      JE=JE+60
      GO TO 10
20    CONTINUE
      CLOSE(UNIT=IDEV)
      RETURN
      END
C
C     LWRAP
      INTEGER FUNCTION LWRAP(IDIM,I)
C   AUTHOR: RODGER STADEN
C   TEST FOR END OF ARRAY,IFSO WRAP AROUND
      LWRAP=I
      IF(LWRAP.GT.IDIM)LWRAP=LWRAP-IDIM
      RETURN
      END
      SUBROUTINE FMT4LN(SEQ1,SEQ2,MATCH,IDIM,ISW,ISX,IDEV)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ1(IDIM),SEQ2(IDIM),MATCH(IDIM)
      INTEGER KL(6)
      ISXX=ISX
      ISWW=ISW
      IE=0
10    CONTINUE
      IS=IE+1
      IE=IE+60
      IF(IE.GT.IDIM)IE=IDIM
      N=IE-IS+1
      N=1+(N-1)/10
C   SET UP DECIMAL COUNTERS
      DO 50 J=1,N
        KL(J)=ISWW
        ISWW=ISWW+10
50    CONTINUE
      WRITE(IDEV,1001)(KL(K),K=1,N)
      WRITE(IDEV,1002)(SEQ1(K),K=IS,IE)
      WRITE(IDEV,1002)(MATCH(K),K=IS,IE)
      WRITE(IDEV,1002)(SEQ2(K),K=IS,IE)
1002  FORMAT( 10X,6(10A1,1X))
C   SET UP DECIMAL COUNTERS
      DO 60 J=1,N
        KL(J)=ISXX
        ISXX=ISXX+10
60    CONTINUE
      WRITE(IDEV,1001)(KL(K),K=1,N)
1001  FORMAT( 5X,6(I6,5X))
      IF(IE.EQ.IDIM)RETURN
      GO TO 10
      END
      SUBROUTINE SQMTCH(SEQ1,SEQ2,MATCH,IDIM)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ1(IDIM),SEQ2(IDIM),MATCH(IDIM),BLANK,STAR
      INTEGER CTONUM
      EXTERNAL CTONUM
      SAVE BLANK,STAR
      DATA BLANK/' '/,STAR/'*'/
      CALL FILLC(MATCH,IDIM,BLANK)
C   LOOK FOR MATCHES
      DO 20 I=1,IDIM
        IF(CTONUM(SEQ1(I)).EQ.CTONUM(SEQ2(I)))MATCH(I)=STAR
20    CONTINUE
      RETURN
      END
      SUBROUTINE GETMRG(ISXMAX,ISYMAX,MARGL,MARGR,MARGB,MARGT,IMARG,
     +IDEVM,FILNAM)
C   AUTHOR: RODGER STADEN
      INTEGER MARGB(IMARG),MARGT(IMARG),OPTION
      CHARACTER FILNAM*(*)
      DO 5 I=1,IMARG
      MARGB(I)=0
      MARGT(I)=0
5     CONTINUE
C      OPEN(UNIT=IDEVM,FILE=FILNAM,STATUS='OLD',READONLY,ERR=4)
      CALL OPENRS(IDEVM,FILNAM,IOK,LRECL,2)
      IF(IOK.NE.0)GO TO 4
C  READ TITLE
      READ(IDEVM,1002)
1002  FORMAT()
        READ(IDEVM,1000,ERR=3)ISXMAX,ISYMAX
        READ(IDEVM,1000,ERR=3)MARGL,MARGR
1000  FORMAT(2I6)
1     CONTINUE
      READ(IDEVM,1001,ERR=3,END=2)OPTION,M1,M2
1001  FORMAT(3I6)
      IF(OPTION.LE.IMARG)THEN
        MARGB(OPTION)=M1
        MARGT(OPTION)=M2
      END IF
      GO TO 1
2     CONTINUE
      CLOSE(UNIT=IDEVM)
      RETURN
3     CONTINUE
      WRITE(*,*)' Error in margin file'
      CLOSE(UNIT=IDEVM)
      RETURN
4     CONTINUE
      WRITE(*,*)' Error opening margin file'
      CLOSE(UNIT=IDEVM)
      RETURN
      END
      SUBROUTINE MOVEC(SEQ,IDIMX,IDIM,IPOS,NCHAR1)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIMX)
      INTEGER TO,FROM
      NCHAR=ABS(NCHAR1)
C   LEFT OR RIGHT?
      IF(NCHAR1.LT.0)GO TO 20
C   RIGHT
      FROM=IDIM
      TO=IDIM+NCHAR
C   NUMBER TO MOVE?
      NUM=IDIM-IPOS+1
      DO 10 I=1,NUM
      SEQ(TO)=SEQ(FROM)
      TO=TO-1
      FROM=FROM-1
10    CONTINUE
      RETURN
20    CONTINUE
C   LEFT
      FROM=IPOS+NCHAR
      TO=IPOS
C   NUMBER TO MOVE?
      NUM=IDIM-FROM+1
      DO 30 I=1,NUM
      SEQ(TO)=SEQ(FROM)
      TO=TO+1
      FROM=FROM+1
30    CONTINUE
      RETURN
      END
      CHARACTER*(*) FUNCTION ATOS(ARRAY,IDIM)
C   AUTHOR RODGER STADEN
      CHARACTER ARRAY(IDIM)
C   FUNCTION TO CONVERT A CHARACTER ARRAY INTO A CHARACTER STRING
      ATOS=' '
      DO 10 I=1,IDIM
        ATOS(I:I)=ARRAY(I)
10    CONTINUE
      RETURN
      END
      SUBROUTINE FILLC(SEQ,IDIM,CH)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDIM),CH
      DO 10 I=1,IDIM
        SEQ(I) = CH
10    CONTINUE
      RETURN
      END
C   FILLI
      SUBROUTINE FILLI(SEQ,IDIM,CH)
C   AUTHOR: RODGER STADEN
      INTEGER SEQ(IDIM),CH
      DO 10 I=1,IDIM
        SEQ(I) = CH
10    CONTINUE
      RETURN
      END
      SUBROUTINE FILLR(ARRAY,IDIM,CH)
C   AUTHOR RODGER STADEN
      REAL ARRAY(IDIM),CH
C  ROUTINE TO FILL REAL ARRAY WITH VALUE CHAR
      DO 10 I = 1 , IDIM
        ARRAY(I) = CH
10    CONTINUE
      END
      SUBROUTINE GETMAT(IDEV,FILNAM,MATRIX,IDM,CHRSET,KBOUT,IOK)
C   AUTHOR RODGER STADEN
      INTEGER MATRIX(IDM,IDM)
      CHARACTER FILNAM*(*),CHRSET(IDM)
      CALL OPENRS(IDEV,FILNAM,IOK,LRECL,2)
      IF(IOK.NE.0)THEN
        WRITE(KBOUT,*)'Error opening score matrix file'
        RETURN
      END IF
      READ(IDEV,1000)
      DO 6 I=1,IDM
        READ(IDEV,1000,ERR=100)CHRSET(I),(MATRIX(I,K),K=1,IDM)
1000    FORMAT(A1,26I3)
6     CONTINUE
      CLOSE(UNIT=IDEV)
      RETURN
100   CONTINUE
      WRITE(KBOUT,*)'Error reading score matrix file'
      CLOSE(UNIT=IDEV)
      IOK = 1
      END
C
      SUBROUTINE REDCOD(SUM,IDEV)
C   AUTHOR: RODGER STADEN
      REAL SUM(4,4,4)
      READ(IDEV,1000)
1000  FORMAT( )
      DO 10 I=1,4
      DO 20 K=1,4
20    READ(IDEV,1001,ERR=30,END=30)(SUM(I,J,K),J=1,4)
10    READ(IDEV,1000,ERR=30,END=30)
1001  FORMAT(5X,4(6X,F5.0))
      RETURN
30    CONTINUE
      WRITE(*,*)' Error reading codon table file'
      END
C
      SUBROUTINE WRTCOD(SUM,IDEV,PAA)
C   AUTHOR: RODGER STADEN
      REAL SUM(4,4,4)
      CHARACTER BASE(4),PAA(5,5,5)
      SAVE BASE
      DATA BASE/'T','C','A','G'/
C
      WRITE(IDEV,1001)
1001  FORMAT(6X,'===========================================')
      DO 10 I=1,4
      DO 20 K=1,4
      WRITE(IDEV,1000)(PAA(K,J,I),
     +BASE(I),BASE(J),BASE(K),SUM(I,J,K),J=1,4)
20    CONTINUE
10    WRITE(IDEV,1001)
1000  FORMAT(5X,4(1X,A1,1X,3A1,F5.0))
      END
      INTEGER FUNCTION NORP(SEQ,IDSEQ)
C   AUTHOR RODGER STADEN
      CHARACTER SEQ(IDSEQ),CHAR1,DNAC*5
      CHARACTER TUPPER
      SAVE DNAC
      EXTERNAL TUPPER
      DATA DNAC/'ATCGU'/
C   RETURNS NORP = 5 IF >85% A,C,G,T,U  ELSE NORP = 26
      DNA = 0.
      DO 10 I = 1,IDSEQ
        CHAR1 = TUPPER(SEQ(I))
        DO 5 J=1,5
          IF(CHAR1.EQ.DNAC(J:J)) THEN
            DNA = DNA + 1.
            GO TO 10
          END IF
 5        CONTINUE
10    CONTINUE
      X = DNA/REAL(IDSEQ)
      N = 26
      IF(X.GT.0.85) N = 5
      NORP = N
      END
      SUBROUTINE COPYI(IN,OUT,ID)
C   AUTHOR RODGER STADEN
      INTEGER IN(ID),OUT(ID)
C   COPY INTEGER ARRAY IN TO ARRAY OUT
      DO 10 I = 1, ID
        OUT(I) = IN(I)
10    CONTINUE
      END
      SUBROUTINE CONNUM(SEQIN,SEQOUT,IDIM)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQIN(IDIM)
      INTEGER SEQOUT(IDIM)
      INTEGER CTONUM
      EXTERNAL CTONUM
      DO 10 I=1,IDIM
        SEQOUT(I)=CTONUM(SEQIN(I))
10    CONTINUE
      RETURN
      END
      SUBROUTINE CONNUN(SEQIN,SEQOUT,IDIM)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQIN(IDIM)
      INTEGER SEQOUT(IDIM)
      INTEGER DTONUM
      EXTERNAL DTONUM
      DO 10 I=1,IDIM
        SEQOUT(I) = DTONUM(SEQIN(I))
10    CONTINUE
      END
      INTEGER FUNCTION NMMTCH(S1,S2)
C   AUTHOR RODGER STADEN
C   RETURNS 0 = MATCH, 1 = NO MATCH
C   Blank names do not match ie all spaces
      CHARACTER S1*(*),S2*(*)
      NMMTCH = 1
      L1 = LEN(S1)
      L2 = LEN(S2)
      L1S = INDEX(S1,' ')
      L2S = INDEX(S2,' ')
      IF(L1S.GT.1) L1 = L1S - 1
      IF(L2S.GT.1) L2 = L2S - 1
      IF(L1.NE.L2) RETURN
      CALL CCASE(S1,2)
      CALL CCASE(S2,2)
      IF(S1(1:L1).NE.S2(1:L1)) RETURN
      NMMTCH = 0
      END
      INTEGER FUNCTION ITOSL(LINE,N)
C Sent int N return its character string left justified
C and the length of the string. Length 0 means error.
      CHARACTER STRING*10,LINE*(*)
      ITOSL = 0
      WRITE(STRING,1000,ERR=100)N
1000  FORMAT(I10)
      CALL LJST(STRING)
      I = INDEX(STRING,' ') - 1
      LINE(1:I) = STRING(1:I)
      ITOSL = I
100   CONTINUE
      END
      SUBROUTINE LJST(STRING)
C Left justify a string, fill rest with spaces
      CHARACTER STRING*(*)
      EXTERNAL NOTILR
      L = LEN(STRING)
      I = NOTILR(STRING,L,' ')
      IF(I.NE.1) THEN
        J = 1
        DO 10 K = I,L
          STRING(J:J) = STRING(K:K)
          J = J + 1
10      CONTINUE
        STRING(J:L) = ' '
      END IF
      END
      SUBROUTINE DIVR(S,N,D)
C Divide array S of N elements by D
      REAL S(N)
      IF(D.NE.0.) THEN
        DO 10 I=1,N
          S(I) = S(I)/D
10      CONTINUE
      END IF
      END
      REAL FUNCTION SUMR(R,N)
C Sum the N elements of array R
      REAL R(N)
      S = 0.
      DO 10 I = 1,N
        S = S + R(I)
10    CONTINUE
      SUMR = S
      END
      LOGICAL FUNCTION NUMBER(CHR)
C Return true if CHR is a digit
      CHARACTER CHR,NUMS*10
      SAVE NUMS
      DATA NUMS/'0123456789'/
      NUMBER = .FALSE.
      IF(INDEX(NUMS,CHR).NE.0) NUMBER = .TRUE.
      END
      INTEGER FUNCTION LASTN(LINEIN,K)
C Return position of last digit (moving left to right) in LINEIN
      CHARACTER LINEIN*(*)
      LOGICAL NUMBER
      EXTERNAL NUMBER
      LASTN = 0
      DO 10 I = K,LEN(LINEIN)
C       CALL OUTPT(LINEIN)(I:I)
        IF(.NOT.(NUMBER(LINEIN(I:I)))) RETURN
        LASTN = I
10    CONTINUE
      END
      INTEGER FUNCTION FIRSTN(LINEIN,K)
C Return position of first digit (moving left to right) in LINEIN
      CHARACTER LINEIN*(*)
      LOGICAL NUMBER
      EXTERNAL NUMBER
      DO 10 I = K,LEN(LINEIN)
C       CALL OUTPT(LINEIN)(I:I)
        FIRSTN = I
        IF(NUMBER(LINEIN(I:I))) RETURN
10    CONTINUE
      FIRSTN = 0
      END
      LOGICAL FUNCTION ONEOF(CHRS,CHR)
C Return true if CHR is in set of chars stored in CHRS
      CHARACTER CHR,CHRS*(*)
      ONEOF = .FALSE.
      IF(INDEX(CHRS,CHR).NE.0) ONEOF = .TRUE.
      END
      LOGICAL FUNCTION STRNGM(S1,S2)
C Return true if the first L chars of S1 and S2 match
C L is the length of the shortest string. Independent of case.
      CHARACTER S1*(*),S2*(*),TUPPER
      EXTERNAL TUPPER
      L = MIN(LEN(S1),LEN(S2))
      STRNGM = .FALSE.
      DO 10 I = 1,L
       IF(TUPPER(S1(I:I)).NE.TUPPER(S2(I:I))) RETURN
10    CONTINUE
      STRNGM = .TRUE.
      END
C   OPENF1
C   IWRITE NE 0 MEANS WRITE NEW FILE, ELSE MEANS READONLY
      SUBROUTINE OPENF1(IDEV,FILNAM,IWRITE,IOK,KBIN,KBOUT,
     +PROMPT,
     +IHELPS,IHELPE,HELPF,IDEVH)
C   AUTHOR: RODGER STADEN
      CHARACTER FILNAM*(*),HELPF*(*),PROMPT*(*)
      PARAMETER (MAXPRM = 16, MAXNAM = 60)
      CHARACTER PERR(2)*(MAXPRM),NEWFN*(MAXNAM)
      INTEGER ANS,DELF
      EXTERNAL DELF,NOTRL
      IOK=1
      ICOUNT = 0
C
      LENGTH = NOTRL(FILNAM,LEN(FILNAM),' ')
      IF(IWRITE.EQ.1) LENGTH = 0
      LIN = LENGTH
10    CONTINUE
      IF(ICOUNT.EQ.5) THEN
        IOK = 1
        RETURN
      END IF
      ICOUNT = ICOUNT + 1
      CALL GTSTR(PROMPT,FILNAM,NEWFN,LENGTH,KBOUT,KBIN,K)
      IF(K.EQ.1) THEN
        CALL HELP2(IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        ICOUNT = 0
        GO TO 10
      END IF
      IF(K.EQ.2) THEN
        IOK = 2
        RETURN
      END IF
C if no default and blank line try again
      IF((K.EQ.3).AND.(LIN.EQ.0)) GO TO 10
      IF(K.EQ.4) GO TO 10
      IF(LENGTH.GT.0) FILNAM = NEWFN
      IF(IWRITE.EQ.0) THEN
C       OLD FILE (I.E. READ ONLY)
        CALL OPENRS(IDEV,FILNAM,IOK,LRECL,2)
        IF(IOK.EQ.0) RETURN
C problem opening file
        IF(IOK.EQ.3) CALL ERROM(KBOUT,'File not found')
        CALL YESNO(ANS,'Retype file name',
     +  IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
        IF(ANS.EQ.0) GO TO 10
        RETURN
      ELSE IF(IWRITE.EQ.1) THEN
C       NEW FILE (I.E. WRITE)
 20     CONTINUE
        CALL OPENRS(IDEV,FILNAM,IOK,LRECL,1)
        IF(IOK.EQ.0) RETURN
C problem opening file
        IF(IOK.EQ.2) THEN
          CALL ERROM(KBOUT,'File already exists')
          PERR(1) = 'Retype file name'
          PERR(2) = 'Replace file'
          IDO = 1
          CALL RADION('Select action',PERR,2,IDO,
     +    IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
          IF(IDO.LT.1) RETURN
          IF(IDO.EQ.1) GO TO 10
          IF(IDO.EQ.2) THEN
            IOK = DELF(FILNAM,IDEV,JRECL,2)
            IF(IOK.EQ.0) GO TO 20
            CALL ERROM(KBOUT,'File delete failed')
            RETURN
          END IF
        ELSE
          CALL ERROM(KBOUT,'File opening failed')
          CALL YESNO(ANS,'Retype file name',
     +    IHELPS,IHELPE,HELPF,IDEVH,KBIN,KBOUT)
          IF(ANS.EQ.0) GO TO 10
          RETURN
        END IF
      END IF
      END
      INTEGER FUNCTION GNFFOF(IDEV,NAME)
      CHARACTER NAME*(*)
      EXTERNAL NOTLR
C
C routine to read a file of file names and return a name
C deals with leading spaces and trims names at first space
C after name: eg '  fred is a bum' is returned as 'fred'
C needed because file names can contain spaces (not our file names!)
C and the open statement expects the names to match precisely
C
C return 0 = ok, 2 = empty line in file, 3 = error in read, 1 = end of file
C
      READ(IDEV,1000,ERR=100,END=200)NAME
 1000 FORMAT(A)
C
C get first non space position
C
      LENGTH = LEN(NAME)
      I = NOTLR(NAME,LENGTH,' ')
C empty line ?
      IF(I.EQ.0) THEN
        GNFFOF = 2
        RETURN
      END IF
C now want first space after I
      J = INDEX(NAME(I+1:),' ')
      IF(J.EQ.0) THEN
        J = LENGTH
      ELSE
        J = J + I - 1
      END IF
      CALL SHFTLS(NAME,I,1,J)
      NAME(J-I+2:) = ' '
      GNFFOF = 0
      RETURN
 100  CONTINUE
      GNFFOF = 3
      RETURN
 200  CONTINUE
      GNFFOF = 1
      END
      SUBROUTINE WRITFF(IDEV,SEQ,IDSEQ,ENAME,TITLE)
C   AUTHOR: RODGER STADEN
      CHARACTER SEQ(IDSEQ),NL,ENAME*(*),TITLE*(*)
      NL = CHAR(10)
      CALL WRITEB('>',1,IDEV)
      CALL WRITEB(ENAME,LEN(ENAME),IDEV)
      CALL WRITEB(' ',1,IDEV)
      CALL WRITEB(TITLE,LEN(TITLE),IDEV)
      CALL WRITEB(NL,1,IDEV)
      JS=1
      JE=60
10    CONTINUE
      IF (JE.GT.IDSEQ) JE = IDSEQ
      DO 5 I=JS,JE
        CALL WRITEB(SEQ(I),1,IDEV)
 5    CONTINUE
      CALL WRITEB(NL,1,IDEV)
      IF(JE.NE.IDSEQ) THEN
        JS=JE+1
        JE=JE+60
        GO TO 10
      END IF
      END
      SUBROUTINE SHFTLS(STRING,FROMS,TO,FROME)
      CHARACTER STRING*(*)
      INTEGER FROMS,TO,FROME
C
C shift a string left from froms to to
C
      J = TO
      DO 10 I=FROMS,FROME
        STRING(J:J) = STRING(I:I)
        J = J + 1
 10   CONTINUE
      END
