1660 lines
44 KiB
Fortran
1660 lines
44 KiB
Fortran
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
|