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

1660 lines
44 KiB
Fortran
Raw Permalink Blame History

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
Reference in New Issue View Git Blame Copy Permalink