Trailing-Edge
-
PDP-10 Archives
-
decuslib10-06
-
43,50430/f4subs.f4
There are no other files named f4subs.f4 in the archive.
SUBROUTINE SUMMD1(ISN,IST,MAXSIT,MAXSPC,ROW1)
REAL ISN(MAXSIT,1),IST(MAXSIT,1),ROW1(1)
C
C REDUCE '3D' TO '2D' BY TAKING SUM ALONG A ROW
C
DO 15 J=1,MAXSPC
DO 10 I=1,MAXSIT
ROW1(I) = IST(I,J)
IF(ISN(I,J) .EQ. 0) ROW1(I) = 99999
10 CONTINUE
CALL WDSKA(ROW1,MAXSIT)
15 CONTINUE
RETURN
END
SUBROUTINE SUMMD2(ITN,ITT,MAXSES,MAXSPC,ROW1)
C
C SIMILAR TO SUMMD1
C
REAL ITN(MAXSES,1),ITT(MAXSES,1),ROW1(1)
DO 30 J=1,MAXSPC
DO 25 K=1,MAXSES
ROW1(K) = ITT(K,J)
IF(ITN(K,J) .EQ. 0) ROW1(K) = 99999
25 CONTINUE
CALL WDSKA(ROW1,MAXSES)
30 CONTINUE
RETURN
END
C
C SUBROUTINE TO FETCH,CHECK AND CODIFY THE DESIRED USER OPTIONS
C
SUBROUTINE GETOPT(IF,IDIV,LIST,RED1,RED2)
INTEGER RED1,RED2,ICON(4),IPWR(4),IDISS(4),IPDISS(4),
1IDEN(4),ITTPRT(5),IPCA(4),ICD(4),ITT(2),ISORT(4)
DIMENSION ILIST(2),IDINT(7),IR(4),ICDIT(5),ISINT(0/8),IFMT(2)
IMPLICIT INTEGER (B)
COMMON KI,KO,INDSK,IODSK
C
C DATA FOR INTERPRETATION
C
DATA ILIST/'AVGE SRVAL'/
DATA IR/'L T+1AVGE L A+1 T '/
DATA ICDIT/'POWERSTDZENONE DEVN * * *'/
DATA IDINT/'BC MM CM DSQRDMTCH RATIO* * *'/
DATA ISINT/'N/A NN FN GA SA CTD ISS VARNCFLX'/
DATA IFMT/'ENTTYATTR'/
DATA ITTPRT/'LOGGDUNLGDBOTH NOTRQ* * *'/
DATA ISPC,ITSPC/' ',"003777777777/
C
C READ OPTIONS AND ECHO THEM
C
READ(KI,5)IF,IDIV,LIST,B2,RED1,RED2,B3,ICON,B4,IPWR,B5,
1 IDISS,B6,IPDISS,B7,ISORT,B8,IDEN,B9,ITT,B10,IPCA,B11,ICD
5 FORMAT(A1,I3,A1,A3,8A1,4I1,11A1,4A1,5A1,A3,8A1,4I1)
WRITE(KO,6)IF,IDIV,LIST,B2,RED1,RED2,B3,ICON,B4,IPWR,B5,
1 IDISS,B6,IPDISS,B7,ISORT,B8,IDEN,B9,ITT,B10,IPCA,B11,ICD
6 FORMAT('0',A1,I3,A1,A3,8A1,4A1,11A1,4A1,5A1,A3,8A1,4I1,/,
1 '0INTERPETATION:',/,1X,13('-')/)
C
C TEST FOR MISALIGNED FIELDS
C
BT=B2.OR.B3.OR.B4.OR.B5.OR.B6.OR.B7.OR.B8.OR.B9.OR.B10.OR.B11
IF(BT.NE.' ')GO TO 100
C
C CARD INPUT FORMAT OPTION
C
K=1
CALL RNCHUP(IF,'E',K,1)
CALL RNCHUP(IF,'A',K,2)
IF(K.NE.2)GO TO 110
WRITE(KO,900)IFMT(IF)
900 FORMAT(' INPUT FORMAT IS ',A5)
C
C DIVIDE CONSTANT OPTION
C
IF(IDIV.LT.1)IDIV=1
IF(IDIV.NE.1)WRITE(KO,916)IDIV
916 FORMAT(' TO BE DIVIDED BY ',I3)
C
C LISTING OPTION
C
K=1
CALL RNCHUP(LIST,'A',K,1)
CALL RNCHUP(LIST,'S',K,2)
IF(K.NE.2)GO TO 110
WRITE(KO,901)ILIST(LIST)
901 FORMAT(' LISTING OPTION - ',A5/)
C
C FIRST AND SECOND REDUCTION OPTIONS
C
CALL RNCHUP(RED1,'T',K,1)
CALL RNCHUP(RED1,'A',K,2)
CALL RNCHUP(RED1,'L',K,3)
CALL RNCHUP(RED1,'S',K,4)
CALL RNCHUP(RED1,' ',K,5)
IF(K.NE.3)GO TO 110
C
K=2
CALL RNCHUP(RED2,'T',K,1)
CALL RNCHUP(RED2,'A',K,2)
CALL RNCHUP(RED2,'L',K,3)
CALL RNCHUP(RED2,'S',K,4)
CALL RNCHUP(RED2,' ',K,5)
IF(K.NE.3)GO TO 110
IF(RED1.EQ.5.AND.RED2.EQ.5)RED1=2
NORED1=RED1.EQ.5
NORED2=RED2.EQ.5
IF(RED1.NE.5)WRITE(KO,902)IR(RED1)
902 FORMAT(' ENT1/ATTR MATRIX PRODUCTION - ',A5)
IF(RED2.NE.5)WRITE(KO,903)IR(RED2)
903 FORMAT(' ENT2/ATTR MATRIX PRODUCTION - ',A5/)
C
C REQUIRED CONDITIONING OPTION
C
WRITE(KO,915)
IF(.NOT.NORED2)WRITE(KO,931)
WRITE(KO,950)
DO 10 J=1,4
K=3
CALL RNCHUP(ICON(J),'P',K,1)
CALL RNCHUP(ICON(J),'S',K,2)
CALL RNCHUP(ICON(J),'N',K,3)
CALL RNCHUP(ICON(J),'V',K,4)
CALL RNCHUP(ICON(J),' ',K,5)
IF(K.NE.4)GO TO 110
IF(NORED2.AND.J.GE.3)GO TO 10
WRITE(KO,904)J,ICDIT(ICON(J))
904 FORMAT(' MATRIX ',I1,' TRANSFORMATION - ',A5)
10 CONTINUE
IF(NORED1.AND.ICON(1).NE.5)WRITE(KO,130)
IF(NORED1.AND.ICON(2).NE.5)WRITE(KO,130)
IF(NORED2.AND.ICON(3).NE.5)WRITE(KO,130)
IF(NORED2.AND.ICON(4).NE.5)WRITE(KO,130)
WRITE(KO,950)
950 FORMAT(1X)
C
C POWER FOR P OPTION
C
IFFL=.FALSE.
DO 15 J=1,4
IF(ICON(J)-1)15,14,15
14 K=4
IFFL=.TRUE.
CALL RANGEC(IPWR(J),1,9,K)
IF(K.NE.5)GOTO 110
IF(NORED2.AND.J.GE.3)GO TO 15
WRITE(KO,905)J,IPWR(J)
905 FORMAT(' POWER TO CONDITION MATRIX ',I1,' - 1/',I1)
15 CONTINUE
IF(IFFL)WRITE(KO,950)
C
C THE DISSIMILARITY OPTION
C
DO 20 J=1,4
K=5
CALL RNCHUP(IDISS(J),'B',K,1)
CALL RNCHUP(IDISS(J),'M',K,2)
CALL RNCHUP(IDISS(J),'C',K,3)
CALL RNCHUP(IDISS(J),'D',K,4)
CALL RNCHUP(IDISS(J),'A',K,5)
CALL RNCHUP(IDISS(J),'R',K,6)
CALL RNCHUP(IDISS(J),' ',K,7)
IF(K.NE.6)GO TO 110
IF(NORED2.AND.J.GE.3)GO TO 20
WRITE(KO,906)J,IDINT(IDISS(J))
906 FORMAT(' MATRIX ',I1,' DISSIMILARITY - ',A5)
IF(IDISS(J).NE.7.AND.ICON(J).EQ.5)WRITE(KO,131)J,J
20 CONTINUE
WRITE(KO,950)
C
C TRELLICE PRINTOUT REQUESTS
DO 25 J=1,4
K=6
CALL RNCHUP(IPDISS(J),'Y',K,.TRUE.)
CALL RNCHUP(IPDISS(J),'N',K,.FALSE.)
CALL RNCHUP(IPDISS(J),' ',K,.FALSE.)
IF(K.NE.7)GO TO 110
IF(NORED2.AND.J.GE.3)GO TO 25
INOT=' NOT '
IF(IPDISS(J))INOT=ISPC.OR.ITSPC
WRITE(KO,907)J,INOT
907 FORMAT(' TRELLICE ',I1,' IS',A5,'REQUIRED')
25 CONTINUE
WRITE(KO,950)
C
C SORTING OPTION
C
DO 30 J=1,4
K=7
CALL RNCHUP(ISORT(J),' ',K,0)
CALL RNCHUP(ISORT(J),'N',K,1)
CALL RNCHUP(ISORT(J),'F',K,2)
CALL RNCHUP(ISORT(J),'G',K,3)
CALL RNCHUP(ISORT(J),'A',K,4)
CALL RNCHUP(ISORT(J),'C',K,5)
CALL RNCHUP(ISORT(J),'I',K,6)
CALL RNCHUP(ISORT(J),'V',K,7)
CALL RNCHUP(ISORT(J),'X',K,8)
IF(K.NE.8)GO TO 110
IF(NORED2.AND.J.GE.3)GO TO 30
L=ISORT(J)
WRITE(KO,910)J,ISINT(L)
910 FORMAT(' MATRIX ',I1,' SORTING - ',A5)
IF(IDISS(J).EQ.7.AND.(ISORT(J).GE.1))WRITE(KO,133)J
30 CONTINUE
WRITE(KO,950)
C
C DENDROGRAM REQUESTS
C
DO 35 J=1,4
K=8
CALL RNCHUP(IDEN(J),'L',K,1)
CALL RNCHUP(IDEN(J),'P',K,2)
CALL RNCHUP(IDEN(J),'B',K,3)
CALL RNCHUP(IDEN(J),'Y',K,2)
CALL RNCHUP(IDEN(J),'N',K,0)
CALL RNCHUP(IDEN(J),' ',K,0)
IF(K.NE.9)GO TO 110
IF(NORED2.AND.J.GE.3)GO TO 35
INOT=' NOT '
IF(IDEN(J) .GT. 0)INOT=ISPC.OR.ITSPC
WRITE(KO,911)J,INOT
911 FORMAT(' DENDROGRAM ',I1,' IS',A5,'REQUIRED')
IF(IDEN(J).AND.ISORT(J).EQ.0)WRITE(KO,134)J
35 CONTINUE
WRITE(KO,950)
C
C TWO WAY TABLE REQUESTS
C
DO 40 J=1,2
K=9
CALL RNCHUP(ITT(J),'L',K,1)
CALL RNCHUP(ITT(J),'U',K,2)
CALL RNCHUP(ITT(J),'B',K,3)
CALL RNCHUP(ITT(J),'N',K,4)
CALL RNCHUP(ITT(J),' ',K,5)
L = (J-1)*2+1
DENDNE = (IDEN(L) .GT. 0) .AND. (IDEN(L+1) .GT. 0)
IF(ITT(J) .LE. 3 .AND. (.NOT. DENDNE)) WRITE(KO,140) J
IF(K.NE.10)GO TO 110
IF(NORED2.AND.J.GT.1)GO TO 40
L=ITT(J)
WRITE(KO,912)J,ITTPRT(L)
912 FORMAT(' TWO WAY TABLE ',I1,' PRINTING: ',A5)
IF((J.EQ.1).AND.(L.EQ.2.OR.L.EQ.3).AND.(RED1.NE.1).AND.
1 (RED1.NE.3) )WRITE(KO,137)J
IF((J.EQ.2).AND.(L.EQ.2.OR.L.EQ.3).AND.(RED2.NE.1).AND.(RED2.NE.
1 3)) WRITE(KO,137)J
40 CONTINUE
C
C PRINCIPAL COORDINATE ANALYSIS
C
WRITE(KO,950)
DO 45 J=1,4
K=10
CALL RNCHUP(IPCA(J),'R',K,1)
CALL RNCHUP(IPCA(J),'M',K,2)
CALL RNCHUP(IPCA(J),' ',K,0)
CALL RNCHUP(IPCA(J),'N',K,0)
CALL RNCHUP(IPCA(J),'B',K,3)
IF(K.NE.11)GO TO 110
IF(NORED2.AND.J.GE.3)GO TO 45
IF(((IPCA(J).AND.1).NE.0).AND.IDISS(J).EQ.7)WRITE(KO,135)J
IF (((IPCA(J).AND.2).NE.0).AND.(ICON(J).EQ.5))WRITE(KO,136)J
INOT=' NOT '
IF(((IPCA(J).AND.1).NE.0))INOT=ISPC.OR.ITSPC
WRITE(KO,930)J,INOT
930 FORMAT(' PRIN COORD ANALYSIS OF ',I1,' IS ',A5,' REQUIRED')
INOT=' NOT '
IF(((IPCA(J).AND.2).NE.0))INOT=ISPC.OR.ITSPC
WRITE(KO,932)J,INOT
932 FORMAT(' PRINC COMP ANALYSIS OF ',I1,' IS ',A5,' REQUIRED')
45 CONTINUE
WRITE(KO,950)
C
C NUMBER OF AXES FOR P CD A
C
DO 50 J=1,4
IF(ICD(J).EQ.0)ICD(J)=99999
IF(.NOT.IPCA(J))GO TO 50
WRITE(KO,935)J,ICD(J)
935 FORMAT(' P COORD ANAL ',I1,' AXES REQUIRED - ',I1)
50 CONTINUE
C
C
C WRITE A KEY AND THE DSK PARAMETERS
C
915 FORMAT('0KEY TO DERIVED MATRICES',/,1X,23('-'),/,
1 '01 ENT1/ATTR DATA ENT1/ENT1 DISSIMILARITY',/,
2 ' 2 " " ATTR/ATTR DISSIMILARITY')
931 FORMAT( ' 3 ENT2/ATTR DATA ENT2/ENT2 DISSIMILARITY',/,
4 ' 4 " " ATTR/ATTR DISSIMILARITY',/)
WRITE(IODSK)ICON,IPWR,IDISS,IPDISS,ISORT,IDEN,ITT,IPCA,ICD
1 ,RED1,RED2
RETURN
C
C ERROR MESSAGES
C
100 TYPE 105
105 FORMAT(' FIELDS MISALIGNED')
GO TO 120
110 TYPE 115,K
115 FORMAT(' ILLEGAL OPTION IN BLOCK ',I2)
120 CALL EXIT
C
C WARNINGS
C
130 FORMAT(' *WARNING* CONDITIONING REQUIRES AN APPROPRIATE 2D MAT'
1 ,'RIX')
131 FORMAT(' *WARNING* DISSIMILARITY ',I1,'REQUIRES A TRANSFORMAT',
1 'ION FOR ',I1,' FIRST')
132 FORMAT(' *WARNING* CANNOT PRODUCE TRELLICE ',I1,
1 ' WITHOUT DISSIMILARITY ',I1,' BEING DON FIRST')
133 FORMAT(' *WARNING* CANNOT SORT ',I1,' WITH NO DISSIMILARITY FIR'
1 ,'ST')
134 FORMAT(' *WARNING* CANNOT PRODUCE DENDROGRAM ',I1,
1 ' WITH NO SORTING SPECIFIED')
135 FORMAT(' *WARNING* CANNOT PRODUCE PCA ON ',I1,
1' WITHOUT DISSIMILARITY FIRST')
136 FORMAT(' *WARNING* CANNOT PRODUCE PR COMP ANAL OF ',I1,
1 ' WITHOUT MATRIX PRODUCTION FIRST')
137 FORMAT(' ATTEMPT TO DELOG NON-LOGGED DATA ON TWO WAY TABLE ',I1)
140 FORMAT(' *WARNING* FOR TWO-WAY TABLE ',I1,' NEED APPROPRIATE '
1 'PRECEDING DENDROGRAMS')
END
SUBROUTINE RNCHUP(INVAR,ITEST,INCVAR,IREPL)
C
C CHECK VARIABLE INVAR AGAINST ITEST
C IF = THEN ADD 1 TO INCVAR
C AND REPLACE INVAR WITH IREPL
C ELSE RETURN
C
IF(INVAR.NE.ITEST)RETURN
INCVAR=INCVAR+1
INVAR=IREPL
RETURN
END
SUBROUTINE RANGEC(INVAR,IL,IU,INCVAR)
C
C CHECK INVAR TO BE IN THE RANGE IL TO IU (INCLUSIVE
C IF SO ADD 1 TO INCVAR
C
IF(.NOT.(INVAR.LE.IU.AND.INVAR.GE.IL))RETURN
INCVAR=INCVAR+1
RETURN
END
SUBROUTINE GCON(ICON,IPWR,IDEN)
C
C GET OPTIONS FROM DSK FOR CONDIT
C
COMMON KI,KO,INDSK,IODSK
DIMENSION ICON(4),IPWR(4),IFILL(12),IDEN(4)
READ(INDSK)ICON,IPWR,IFILL,IDEN
RETURN
END
SUBROUTINE GBRA(IDISS,TITLE,IPDISS,IDEN)
C
C GET OPTIONS FROM DSK FOR BRACUR
C
COMMON KI,KO,INDSK,IODSK
DIMENSION TITLE(13),IF1(3),IF2(8),IDISS(4),IPDISS(4)
1 ,IF3(4),IDEN(4)
CALL IFILE(INDSK,'AVGE')
READ(INDSK)IF1,TITLE
READ(INDSK)IF2,IDISS,IPDISS,IF3,IDEN
CALL RELEAS(INDSK)
RETURN
END
SUBROUTINE GDEN(IDEN,ISORT)
C
C GET OPTIONS FROM DSK FOR DENDRO
C
COMMON KI,KO,INDSK,IODSK
DIMENSION IF1(16),IF2(3),TITLE(13),ISORT(4),IDEN(4)
CALL IFILE(INDSK,'AVGE')
READ(INDSK)IF2,TITLE
READ(INDSK)IF1,ISORT,IDEN
CALL RELEAS(INDSK)
RETURN
END
SUBROUTINE GPLT(IDEN)
C
C GET OPTIONS FROM DSK FOR DENPLT
C
COMMON KI,KO,INDSK,IODSK
DIMENSION IF1(16),IDEN(4),IF2(20)
CALL IFILE(INDSK,'AVGE')
READ(INDSK)IF1
READ(INDSK)IF2,IDEN
CALL RELEAS(INDSK)
RETURN
END
SUBROUTINE GPCA(IDISS,IPCA,ICD)
COMMON KI,KO,INDSK,IODSK
DIMENSION IF1(16),IPCA(4),ICD(4),IF2A(8),IDISS(4),IF2B(14)
C
C GET OPTIONS FROM DSK FOR PCA
C
CALL IFILE(INDSK,'AVGE')
READ(INDSK)IF1
READ(INDSK)IF2A,IDISS,IF2B,IPCA,ICD
CALL RELEAS(INDSK)
RETURN
END
SUBROUTINE INIT
C
C SET UNIT NUMBERS FOR DSK
C AND TTY IF NOT IN BATCH
C OR CDR,LPT IF IN BATCH
C
COMMON KI,KO,IDSK,IODSK
IDSK=20
IODSK=21
KI=2
KO=3
IF(BATCH(0))RETURN
KI=5
KO=6
RETURN
END
SUBROUTINE DIMFND(MAXSIT,MAXSES,MAXSPC,TITLE)
C
C GET THE FULL DIMENSIONS OF OUR PROBLEM
C THEN STORE THEM INAVGE.DAT
C
DIMENSION TITLE(13)
COMMON KI,KO,INDSK,IODSK
READ(KI,5)MAXSIT,MAXSES,MAXSPC,TITLE
IF(MAXSIT.EQ.0)MAXSIT=1
IF(MAXSES.EQ.0)MAXSES=1
IF(MAXSPC.EQ.0)MAXSPC=1
5 FORMAT(3I5,13A5)
WRITE(IODSK)MAXSIT,MAXSES,MAXSPC,TITLE
RETURN
END
SUBROUTINE CRDSIT(ISN,IST,ITN,ITT,MAXSIT,MAXSES,MAXSPC,IDIV)
C
C ROUTINE TO GET THE INPUT DECK IN SITE FORMAT
C BUILDS UP THE TWO DIMENSIONAL ARRAYS OF SIT X SPC AND TIM X SPC
C
DIMENSION ICARD(16)
REAL ISN(MAXSIT,1),IST(MAXSIT,1)
REAL ITN(MAXSES,1),ITT(MAXSES,1)
RDIV=FLOAT(IDIV)
COMMON KI,KO
C
C INITIALISE
C
DO 3 I=1,MAXSPC
DO 4 J=1,MAXSIT
ISN(J,I)=MAXSES
4 IST(J,I)=0
DO 3 J=1,MAXSES
ITN(J,I)=MAXSIT
3 ITT(J,I)=0
NSITE=1
NSEAS=1
NSPEC=1
C
C READ A CARD
C
2 READ(KI,5,END=55) ICARD
5 FORMAT(A5,15I5)
IF(ICARD(1).EQ.'*****')GO TO 22
IF(ICARD(1).EQ.'+++++')GO TO 21
IF(ICARD(1).EQ.'-----')GO TO 31
C
C IF A DATA CARD DECODE IT
C
DECODE(5,6,ICARD) ICARD(1)
6 FORMAT(I5)
IF(ICARD(16).EQ.0)ICARD(16)=1
IF(ICARD(15).EQ.0)ICARD(15)=1
IF(ICARD(16).NE.NSITE) GO TO 15
7 IF(ICARD(15).NE.NSEAS) GO TO 20
C
C AND DEPOSIT
C
8 DO 10 J=1,13,2
NSPEC=ICARD(J)
IF(NSPEC.EQ.0) GO TO 2
IF (NSPEC.GT.MAXSPC)GO TO 10
IST(NSITE,NSPEC)=IST(NSITE,NSPEC)+ICARD(J+1)/RDIV
ITT(NSEAS,NSPEC)=ITT(NSEAS,NSPEC)+ICARD(J+1)/RDIV
10 CONTINUE
GO TO 2
C
C NEW PARAMETERS IN LAST TWO COLUMNS
C
15 IF(ICARD(16).GT.MAXSIT)GO TO 2
NSITE=ICARD(16)
GO TO 7
20 IF(ICARD(15).GT.MAXSES)GO TO 2
NSEAS=ICARD(15)
GO TO 8
C
C 'NOT SAMPLED' CARD DECREMENTS COUNT
C
22 DO 37 J=2,14,2
NSITE=ICARD(J)
IF(NSITE.EQ.0)GO TO 2
NSEAS=ICARD(J+1)
IF(NSEAS.GT.MAXSES.OR.NSITE.GT.MAXSIT)GO TO 37
DO 36 K=1,MAXSPC
ISN(NSITE,K)=ISN(NSITE,K)-1
ITN(NSEAS,K)=ITN(NSEAS,K)-1
36 CONTINUE
37 CONTINUE
GO TO 2
C
C +++++ CARD ENT1 ATTR ENT1 ATTR ...
C
21 DO 25 J=1,7
ISI=ICARD(2*J)
ISP=ICARD(2*J+1)
IF(ISI.GT.MAXSIT.OR.ISI.LT.1)GO TO 25
IF(ISP.GT.MAXSPC.OR.ISP.LT.1)GO TO 25
C
DO 24 K=1,MAXSES
24 ITN(K,ISP)=ITN(K,ISP)-1
C
ISN(ISI,ISP)=ISN(ISI,ISP)-MAXSES
C
25 CONTINUE
GO TO 2
C
C ----- CARD ENT2 ATTR ENT2 ATTR ....
C
31 DO 35 J=1,7
ITI=ICARD(2*J)
ISP=ICARD(2*J+1)
IF(ITI.GT.MAXSES.OR.ITI.LT.1)GO TO 35
IF(ISP.GT.MAXSPC.OR.ITI.LT.1)GO TO 35
C
DO 34 K=1,MAXSIT
34 ISN(K,ISP)=ISN(K,ISP)-1
C
ITN(ITI,ISP)=ITN(ITI,ISP)-MAXSIT
35 CONTINUE
GO TO 2
C
C RETURN AT END OF DECK
C
55 RETURN
END
SUBROUTINE CRDSPC(ISN,IST,ITN,ITT,MSIT,MSES,MSPC,IDIV)
C
C READS THE SPECIES FORMAT DECK
C
DIMENSION ICARD(16),ITIM(7),ISIT(7),ISPN(7)
REAL ISN(MSIT,1),IST(MSIT,1)
REAL ITN(MSES,1),ITT(MSES,1)
RDIV=FLOAT(IDIV)
COMMON KI,KO
C
C INITIALISE
C
DO 1 I=1,MSPC
DO 2 J=1,MSIT
ISN(J,I)=MSES
2 IST(J,I)=0
DO 1 J=1,MSES
ITN(J,I)=MSIT
1 ITT(J,I)=0
C
C
C READ A CARD
C
3 READ(KI,4,END=55)ICARD
4 FORMAT(16A5)
IF(ICARD(1).EQ.'*****')GO TO 7
IF(ICARD(1).EQ.'+++++')GO TO 21
IF(ICARD(1).EQ.'-----')GO TO 31
C
C IF A DATA CARD DECODE
C
DECODE(80,5,ICARD)(ITIM(I),ISIT(I),ISPN(I),I=1,7),ISPC
5 FORMAT(7(I3,I2,I5),5X,I5)
IF(ISPC.GT.MSPC.OR.ISPC.LT.1)GO TO 3
C
C AND DEPOSIT
C
DO 6 I=1,7
ISI=ISIT(I)
ITI=ITIM(I)
IF(ITI.EQ.0)ITI=1
IF(ISI.EQ.0)ISI=1
IF(ISI.GT.MSIT.OR.ISI.LT.1)GO TO 6
IF(ITI.GT.MSES.OR.ITI.LT.1)GO TO 6
IST(ISI,ISPC)=IST(ISI,ISPC)+ISPN(I)/RDIV
ITT(ITI,ISPC)=ITT(ITI,ISPC)+ISPN(I)/RDIV
6 CONTINUE
GO TO 3
C
C A 'NOT SAMPLED' CARD
C OF TYPE ENT1 ENT2 ENT1 ENT2 .....
C
7 DECODE(75,8,ICARD(2))(ISIT(I),ITIM(I),I=1,7)
8 FORMAT(14I5)
C
C AND DEPOSIT AND DECREMENT COUNTS
C
DO 9 I=1,7
ISI=ISIT(I)
ITI=ITIM(I)
IF(ISI.GT.MSIT.OR.ISI.LT.1)GO TO 9
IF(ITI.GT.MSES.OR.ITI.LT.1)GO TO 9
C
DO 10 J=1,MSPC
ISN(ISI,J)=ISN(ISI,J)-1
ITN(ITI,J)=ITN(ITI,J)-1
10 CONTINUE
9 CONTINUE
GO TO 3
C
C +++++ CARD ENT1 ATTR ENT1 ATTR ...
C
21 DECODE(75,8,ICARD(2))(ISIT(I),ISPN(I),I=1,7)
C
DO 25 J=1,7
ISI=ISIT(J)
ISP=ISPN(J)
IF(ISI.GT.MSIT.OR.ISI.LT.1)GO TO 25
IF(ISP.GT.MSPC.OR.ISP.LT.1)GO TO 25
C
DO 24 K=1,MSES
24 ITN(K,ISP)=ITN(K,ISP)-1
C
ISN(ISI,ISP)=ISN(ISI,ISP)-MSES
C
25 CONTINUE
GO TO 3
C
C ----- CARD ENT2 ATTR ENT2 ATTR ....
C
31 DECODE(75,8,ICARD(2))(ITIM(I),ISPN(I),I=1,7)
C
DO 35 J=1,7
ITI=ITIM(J)
ISP=ISPN(J)
IF(ITI.GT.MSES.OR.ITI.LT.1)GO TO 35
IF(ISP.GT.MSPC.OR.ISP.LT.1)GO TO 35
C
DO 34 K=1,MSIT
34 ISN(K,ISP)=ISN(K,ISP)-1
C
ITN(ITI,ISP)=ITN(ITI,ISP)-MSIT
35 CONTINUE
GO TO 3
C
C RETURN AT END OF DECK
C
55 RETURN
END
SUBROUTINE LISTC(ISN,IST,ITN,ITT,MAXSIT,MAXSPC,MAXSES)
C
C ROUTINE TO LIST AVERAGE FIGURES AT BEGINNING OF PRINTOUT
C
REAL ISN(MAXSIT,1),IST(MAXSIT,1),ITN(MAXSES,1),ITT(MAXSES,1)
COMMON KI,KO
C
C
C WRITE HEADINGS
WRITE(KO,10)
10 FORMAT(1H1,3X,'AVERAGE ATTRIBUTE OCCURRENCES',/,
14X,29('*'),/,
1'0',3X,'ENT1',6X,'AVGE OCCS',/,
14X,19('-'))
C
C GENERATE AVERAGE OVER ALL SPECIES AND TIMES FOR A SITE
C
DO 15 J=1,MAXSIT
RTOT=0
RNUM=0
DO 17 I=1,MAXSPC
RNUM=RNUM+ISN(J,I)
17 RTOT=RTOT+IST(J,I)
IF(RNUM.EQ.0)RNUM=.00001
RTOT=RTOT/RNUM
15 WRITE(KO,20)J,RTOT
20 FORMAT(5X,I2,9X,F8.2)
C
C HEADINGS
C
IF(MAXSES.LE.1)RETURN
WRITE(KO,25)
25 FORMAT('0',3X,'ENT2',6X,'AVGE OCCS',/,4X,19('-'))
C
C GENERATE AVERAGE OVE ALL SPC + SIT FOR A TIME
C
DO 30 J=1,MAXSES
RNUM=0
RTOT=0
DO 35 I=1,MAXSPC
RNUM=RNUM+ITT(J,I)
35 RTOT=RTOT+ITN(J,I)
IF(RTOT.EQ.0)RTOT=.00001
RTOT=RNUM/RTOT
30 WRITE(KO,20)J,RTOT
C
RETURN
END
SUBROUTINE LISRAW(ISN,IST,ITN,ITT,MAXSIT,MAXSPC,MAXSES)
C
C ROUTINE TO PRINT SUMMATED RAW VALUES
C
REAL ISN(MAXSIT,1),IST(MAXSIT,1),ITN(MAXSES,1),ITT(MAXSES,1)
COMMON KI,KO
C
C HEADINGS
C
WRITE(KO,10)
10 FORMAT(1H1,3X,'SUMMATED ENTITY SCORES',/,
14X,22('*'),/,
1'0',3X,'ENT1',6X,'TOTAL',/,
14X,20('-'))
C
C TOTAL THE INDIVS OVER ALL TIM X SPC FOR A SIT
C
DO 15 J=1,MAXSIT
RTOT=0
RNUM=0
DO 17 I=1,MAXSPC
RNUM=RNUM+ISN(J,I)
17 RTOT=RTOT+IST(J,I)
IF(RNUM.EQ.0)RTOT=999999
15 WRITE(KO,20)J,RTOT
20 FORMAT(5X,I2,9X,F8.2)
C
C HEADINGS
C
IF(MAXSES.LE.1)RETURN
WRITE(KO,25)
25 FORMAT('0',3X,'ENT2',6X,'TOTAL',/,4X,20('-'))
C
C TOTAL OVER ALL SIT + SPC FOR A TIME
C
DO 30 I=1,MAXSES
RTOT=0
RNUM=0
DO 40 J=1,MAXSPC
RNUM=RNUM+ITN(I,J)
40 RTOT=RTOT+ITT(I,J)
IF(RNUM.EQ.0)RTOT=999999
30 WRITE(KO,20)I,RTOT
C
RETURN
END
SUBROUTINE SUMMD1(ISN,IST,MAXSIT,MAXSPC,ROW1)
REAL ISN(MAXSIT,1),IST(MAXSIT,1),ROW1(1)
C
C REDUCE '3D' TO '2D' BY TAKING SUM ALONG A ROW
C
DO 15 J=1,MAXSPC
DO 10 I=1,MAXSIT
ROW1(I) = IST(I,J)
IF(ISN(I,J) .EQ. 0) ROW1(I) = 99999
10 CONTINUE
CALL WDSKA(ROW1,MAXSIT)
15 CONTINUE
RETURN
END
SUBROUTINE SUMMD2(ITN,ITT,MAXSES,MAXSPC,ROW1)
C
C SIMILAR TO SUMMD1
C
REAL ITN(MAXSES,1),ITT(MAXSES,1),ROW1(1)
DO 30 J=1,MAXSPC
DO 25 K=1,MAXSES
ROW1(K) = ITT(K,J)
IF(ITN(K,J) .EQ. 0) ROW1(K) = 99999
25 CONTINUE
CALL WDSKA(ROW1,MAXSES)
30 CONTINUE
RETURN
END
SUBROUTINE LOGRD1(ISN,IST,MAXSIT,MAXSPC,ROW1)
REAL ISN(MAXSIT,1),IST(MAXSIT,1),ROW1(1)
C
C ROUTINE TO REDUCE '3D' TO 2D BY TAKING LOG(T+1)
C WHERE T=TOTAL ALONG A ROW
C
DO 15 J=1,MAXSPC
DO 10 I=1,MAXSIT
ROW1(I)=ALOG10(IST(I,J)+1)
IF(ISN(I,J).EQ.0)ROW1(I)=99999
10 CONTINUE
CALL WDSKA(ROW1,MAXSIT)
15 CONTINUE
END
SUBROUTINE AV1(ISN,IST,MAXSIT,MAXSPC,ROW1)
C
C ROUITINE TO REDUCE '3D' TO 2D BY TAKING AVGE ALONG A ROW
C
REAL ISN(MAXSIT,1),IST(MAXSIT,1),ROW1(1)
DO 15 J=1,MAXSPC
DO 10 I=1,MAXSIT
IF(ISN(I,J).NE.0)ROW1(I)=IST(I,J)/ISN(I,J)
IF(ISN(I,J).EQ.0)ROW1(I)=99999
10 CONTINUE
CALL WDSKA(ROW1,MAXSIT)
15 CONTINUE
RETURN
END
SUBROUTINE LOGAV1(ISN,IST,MAXSIT,MAXSPC,ROW1)
C
C ROUTINE TO CONVERT '3D' TO 2D BY TAKING LOG(A+1)
C WHERE A IS AVERAGE ALONG A ROW
C
REAL ISN(MAXSIT,1),IST(MAXSIT,1),ROW1(1)
DO 15 J=1,MAXSPC
DO 10 I=1,MAXSIT
IF(ISN(I,J).EQ.0)GO TO 5
RTOT=(IST(I,J))/ISN(I,J)
ROW1(I)=ALOG10(RTOT+1)
GO TO 10
5 ROW1(I)=99999
10 CONTINUE
CALL WDSKA(ROW1,MAXSIT)
15 CONTINUE
RETURN
END
SUBROUTINE LOGAV2(ITN,ITT,MAXSES,MAXSPC,ROW1)
C
C ROUTINE TO REDUCE '3D TO 2D BY TAKING LOG(A+1)
C WHERE A IS AVERAGE ALONG A ROW
C
REAL ITN(MAXSES,1),ITT(MAXSES,1),ROW1(1)
DO 30 J=1,MAXSPC
DO 25 K=1,MAXSES
IF(ITN(K,J).EQ.0)GO TO 10
RTOT=(ITT(K,J))/ITN(K,J)
ROW1(K)=ALOG10(RTOT+1)
GO TO 25
10 ROW1(K)=99999
25 CONTINUE
CALL WDSKA(ROW1,MAXSES)
30 CONTINUE
RETURN
END
SUBROUTINE LOGRD2(ITN,ITT,MAXSES,MAXSPC,ROW1)
C
C ROUTINE OF SIMILAR FUNCTION TO LOGRD1
C
REAL ITN(MAXSES,1),ITT(MAXSES,1),ROW1(1)
DO 30 J=1,MAXSPC
DO 25 K=1,MAXSES
ROW1(K)=ALOG10(ITT(K,J)+1)
IF(ITN(K,J).EQ.0)ROW1(K)=99999
25 CONTINUE
CALL WDSKA(ROW1,MAXSES)
30 CONTINUE
RETURN
END
SUBROUTINE AV2(ITN,ITT,MAXSES,MAXSPC,ROW1)
C
C ROUEINR OF SIMILAR FUNCTION TO AV1
C
REAL ITN(MAXSES,1),ITT(MAXSES,1),ROW1(1)
DO 30 J=1,MAXSPC
DO 25 K=1,MAXSES
IF(ITN(K,J).EQ.0)GO TO 10
ROW1(K)=(ITT(K,J))/ITN(K,J)
GO TO 25
10 ROW1(K)=99999
25 CONTINUE
CALL WDSKA(ROW1,MAXSES)
30 CONTINUE
RETURN
END
SUBROUTINE GETARR(ARR,NC,NR)
C
C UTILITY ROUTINE TO READ AN ARRAY FROM DSK
C STORED ONE ROW PER SUCCESSIVE LOGICAL RECORD
C
DIMENSION ARR(NC,1)
COMMON KI,KO,INDSK
DO 5 J=1,NR
5 READ(INDSK)(ARR(I,J),I=1,NC)
RETURN
END
SUBROUTINE PWRNOT(ARR,P,NAME,NC,NR,WARR)
C
C CONDITIONING ROUTINE TO WRITE A COPY OF INPUT ARRAY ARR
C TO DSK AFTER APPLYING CONDITIONING
C
C PWRNOT - RAISES ECH ELEMENT TO POWER 1/P
C - WRITES OUT MATRIX
C - HEADS OUTPUT WITH DIMENSIONS
C
INTEGER P
DIMENSION ARR(NC,1),WARR(1)
COMMON KI,KO,INDSK,IODSK
PLOCAL=1./FLOAT(P)
CALL OFILE(IODSK,NAME)
WRITE(IODSK)NR,NC
DO 10 J=1,NR
DO 5 I=1,NC
IF(ARR(I,J).EQ.99999)GO TO 5
WARR(I)=ARR(I,J)**PLOCAL
5 CONTINUE
WRITE(IODSK)(WARR(I),I=1,NC)
10 CONTINUE
CALL RELEAS(IODSK)
RETURN
END
SUBROUTINE PWRTRN(ARR,P,NAME,NC,NR,WARR)
C
C SAME AS PWRNOT, BUT TRANSPOSE IS WRITTEN OUT
C
INTEGER P
DIMENSION ARR(NC,1),WARR(1)
COMMON KI,KO,INDSK,IODSK
PLOCAL=1./FLOAT(P)
CALL OFILE(IODSK,NAME)
WRITE(IODSK)NC,NR
DO 10 I=1,NC
DO 5 J=1,NR
IF(ARR(I,J).EQ.99999)GO TO 5
WARR(J)=ARR(I,J)**PLOCAL
5 CONTINUE
WRITE(IODSK)(WARR(J),J=1,NR)
10 CONTINUE
CALL RELEAS(IODSK)
RETURN
END
SUBROUTINE STNNOT(ARR,NAME,NC,NR,WORK)
C
C BASIC FUNCTION IS AS FOR PWRNOT
C CONDITIONING IS TO STANDARDIZE ALL ELEMENTS IN A ROW BY ROW TOTAL
C
DIMENSION WORK(1)
DIMENSION ARR(NC,1)
COMMON KI,KO,INDSK,IODSK
CALL OFILE(IODSK,NAME)
WRITE(IODSK)NR,NC
DO 20 J=1,NR
SUM=0.
DO 10 I=1,NC
IF(ARR(I,J).EQ.99999)GO TO 10
SUM=SUM+ARR(I,J)
10 CONTINUE
IF(SUM.EQ.0)GO TO 25
DO 15 I=1,NC
IF(ARR(I,J).EQ.99999)GO TO 15
WORK(I)=ARR(I,J)/SUM
15 CONTINUE
17 WRITE(IODSK)(WORK(I),I=1,NC)
20 CONTINUE
CALL RELEAS(IODSK)
RETURN
25 DO 26 I=1,NC
IF(ARR(I,J).EQ.99999)GO TO 26
WORK(I)=0.
26 CONTINUE
GO TO 17
END
SUBROUTINE STNTRN(ARR,NAME,NC,NR,WORK)
C
C BASIC CONDITIONING AS FOR STNNOT
C TRANSPOSE MATRIX WRITTEN OUT
C ELEMENTS STANDARDISED BY COLUMN TOTL
C
DIMENSION WORK(1)
DIMENSION ARR(NC,1)
COMMON KI,KO,INDSK,IODSK
CALL OFILE(IODSK,NAME)
WRITE(IODSK)NC,NR
DO 20 I=1,NC
SUM=0.
DO 10 J=1,NR
IF(ARR(I,J).EQ.99999)GO TO 10
SUM=SUM+ARR(I,J)
10 CONTINUE
IF(SUM.EQ.0)GO TO 25
DO 15 J=1,NR
IF(ARR(I,J).EQ.99999)GO TO 15
WORK(J)=ARR(I,J)/SUM
15 CONTINUE
17 WRITE(IODSK)(WORK(J),J=1,NR)
20 CONTINUE
CALL RELEAS(IODSK)
RETURN
25 DO 26 J=1,NR
IF(ARR(I,J).EQ.99999)GO TO 26
WORK(J)=0.
26 CONTINUE
GO TO 17
END
SUBROUTINE DEVTRN(ARR,NAME,NC,NR,WORK)
C
CONDITIONING IS TO EXPRESS ELMNT AS SD FROM MEAN IN COLS.
C TRANSPOSE WRITTEN OUT ON OUTPUT
C
DIMENSION ARR(NC,1),WORK(1)
COMMON KI,KO,INDSK,IODSK
CALL OFILE(IODSK,NAME)
WRITE(IODSK)NC,NR
C
C FIND MEAN AND SD IN COLS
C
DO 50 J=1,NC
SUMSQ=0
SUM=0
NHERE=0
C
DO 20 I=1,NR
IF(ARR(J,I).EQ.99999)GO TO 20
T=ARR(J,I)
SUMSQ=SUMSQ+T*T
SUM=SUM+T
NHERE=NHERE+1
20 CONTINUE
C
SDEV=(SUMSQ-(SUM*SUM)/NHERE)/(NHERE-1)
SDEV = SQRT(SDEV)
AVGE=SUM/NHERE
C
DO 25 I=1,NR
IF(ARR(J,I).EQ.99999)GO TO 25
WORK(I)=(ARR(J,I)-AVGE)/SDEV
25 CONTINUE
WRITE(IODSK)(WORK(I),I=1,NR)
C
50 CONTINUE
C
CALL RELEAS(IODSK)
RETURN
END
SUBROUTINE DEVNOT(ARR,NAME,NC,NR,WORK)
C
C CONDITIONING APPLIED IS TO EXPRESS ELEMENT AS STD DEVN FROM
C MEAN IN ROW. NO TRANSPOSE WRITTEN OUT
C
DIMENSION ARR(NC,1),WORK(1)
COMMON KI,KO,INDSK,IODSK
CALL OFILE(IODSK,NAME)
WRITE(IODSK)NR,NC
C
C FIND MEAN AND SDIN ROW
C
DO 50 J=1,NR
SUMSQ=0
SUM=0
NHERE=0
C
DO 20 I=1,NC
IF(ARR(I,J).EQ.99999)GO TO 20
NHERE=NHERE+1
T=ARR(I,J)
SUMSQ=SUMSQ+T*T
SUM=SUM+T
20 CONTINUE
SDEV=(SUMSQ-(SUM*SUM)/NC)/(NHERE-1)
SDEV = SQRT(SDEV)
AVGE=SUM/NHERE
C
DO 25 I=1,NC
IF(ARR(I,J).EQ.99999)GO TO 25
WORK(I)=(ARR(I,J)-AVGE)/SDEV
25 CONTINUE
WRITE(IODSK)(WORK(I),I=1,NC)
C
50 CONTINUE
C
CALL RELEAS(IODSK)
RETURN
END
SUBROUTINE NOTTRN(ARR,NAME,NC,NR)
C
C CONDITIONING ROUTINE WRITES OUT ORIGINAL MATRIX TRANSPOSE
C CONDITIONING IS 'DO NOTHING TO EACH ELEMENT'
C
DIMENSION ARR(NC,1)
COMMON KI,KO,INDSK,IODSK
CALL OFILE(IODSK,NAME)
WRITE(IODSK)NC,NR
DO 30 I=1,NC
30 WRITE(IODSK)(ARR(I,J),J=1,NR)
CALL RELEAS(IODSK)
RETURN
END
SUBROUTINE NOTNOT(ARR,NAME,NC,NR)
C
C WRITES OUT ORIGINAL MATRIX WITH NO TRANSPOSE
C
DIMENSION ARR(NC,1)
COMMON KI,KO,INDSK,IODSK
CALL OFILE(IODSK,NAME)
WRITE(IODSK)NR,NC
DO 30 J=1,NR
30 WRITE(IODSK)(ARR(I,J),I=1,NC)
CALL RELEAS(IODSK)
RETURN
END
SUBROUTINE BRACUR(RIN,NR,NC,WORK)
C
C ROUTINE TO CALCULATE DISSIMILARITY CO-EFFICIENT MATRIX
C
C TAKES ORIGINAL MATRIX NC X NR
C AND PRODUCES AN NC X NC DISS MATRIX
C DISS COEFFICIENTS ARE EXPRESSED AS %
C
C CO-EFFISIENT FOR THIS ROUTINE IS BRAY-CURTIS
C
DIMENSION RIN(NC,1),WORK(NC,1)
DO 30 I=1,NC
DO 30 J=I,NC
RNUM=0.
DEN=0.
DO 20 K=1,NR
EL1=RIN(I,K)
EL2=RIN(J,K)
IF(EL1.EQ.99999.OR.EL2.EQ.99999)GO TO 20
RNUM=RNUM+ABS(EL1-EL2)
DEN=DEN+ABS(EL1+EL2)
20 CONTINUE
WORK(I,J)=0.
IF(DEN.EQ.0)GO TO 25
WORK(J,I)=RNUM/DEN*100.0
30 CONTINUE
RETURN
25 WORK(J,I)=0.
GO TO 30
END
SUBROUTINE MANHAT(RIN,NR,NC,WORK)
C
C BASIC FUNCTION IS AS FOR BRACUR
C CO-EFFICIENT IS MANHATTAN METRIC
C
DIMENSION RIN(NC,1),WORK(NC,1)
DO 30 I=1,NC
DO 30 J=I,NC
RNUM=0.
DO 20 K=1,NR
EL1=RIN(I,K)
EL2=RIN(J,K)
IF(EL1.EQ.99999.OR.EL2.EQ.99999)GO TO 20
RNUM=RNUM+ABS(EL1-EL2)
20 CONTINUE
WORK(I,J)=0.
WORK(J,I)=RNUM
30 CONTINUE
RETURN
END
SUBROUTINE CANBRA(RIN ,NR,NC,WORK)
C
C SIMILARLY CANBERRA METRIC COEFFICIENT
C REVISED TREATMENT OF CASE WHERE DENOMINATOR
C OF RATIO IS ZERO.... CJM FEB 1977
C
DIMENSION RIN(NC,1),WORK(NC,1)
DO 30 I=1,NC
DO 30 J=I,NC
RSUM=0
NHERE=0
DO 20 K=1,NR
EL1=RIN(I,K)
EL2=RIN(J,K)
IF(EL1.EQ.99999.OR.EL2.EQ.99999)GO TO 20
DENOM = EL1 + EL2
IF(DENOM .EQ. 0.0) GO TO 31
RSUM=RSUM+ABS(EL1-EL2)/DENOM
NHERE=NHERE+1
20 CONTINUE
WORK(I,J)=0
WORK(J,I)=(RSUM/NHERE)*100.0
30 CONTINUE
RETURN
31 RSUM = RSUM + 1.0
NHERE = NHERE + 1
GO TO 20
END
SUBROUTINE DSQRD(RIN,NR,NC,WORK)
DIMENSION RIN(NC,1),WORK(NC,1)
C
C EUCLIDEAN DISTANCE MEASURE
C
DO 30 I=1,NC
DO 30 J=I,NC
RSUM=0
DO 20 K=1,NR
IF(RIN(I,K).EQ.99999.OR.RIN(J,K).EQ.99999)GO TO 20
DIFF=RIN(I,K)-RIN(J,K)
RSUM=RSUM+DIFF*DIFF
20 CONTINUE
WORK(I,J)=0
30 WORK(J,I)=RSUM
RETURN
END
SUBROUTINE MATCH(RIN,NR,NC,WORK)
DIMENSION RIN(NC,1),WORK(NC,1)
C
C SIMPLE COUNT OF MATCHES +VE AND -VE - A COEFFICIENT OF
C SIMILARITY RATHER THAN DISSIMILARITY
C SO SUBRACTION IS DONE
C
DO 30 I=1,NC
DO 30 J=I,NC
MATCHS=0
IMISS=0
DO 20 K=1,NR
IF(RIN(I,K).EQ.99999.OR.RIN(J,K).EQ.99999)GO TO 10
IF(RIN(I,K).EQ.RIN(J,K))MATCHS=MATCHS+1
GO TO 20
10 IMISS=IMISS+1
20 CONTINUE
WORK(I,J)=0
30 WORK(J,I)=100.0-(FLOAT(MATCHS)/(NR-IMISS))*100.0
RETURN
END
SUBROUTINE RATIO(RIN,NR,NC,WORK)
DIMENSION RIN(NC,1),WORK(NC,1)
C
C SIMPLE SUM OF RATIOS
C
DO 30 I=1,NC
DO 30 J=I,NC
SUM=0
DO 20 K=1,NR
EL1=RIN(I,K)
EL2=RIN(J,K)
IF(EL1.EQ.99999.OR.EL2.EQ.99999)GO TO 20
RMIN=AMIN1(EL1,EL2)
RMAX=AMAX1(EL1,EL2)
IF(RMIN.EQ.0)GO TO 31
SUM=SUM+RMIN/RMAX
20 CONTINUE
WORK(I,J)=0
30 WORK(J,I)=NR-SUM
RETURN
31 IF(RMAX.EQ.0)SUM=SUM+1
GO TO 20
END
SUBROUTINE LTWR(TM,NC,DFLE,T,ST)
C
C UTILITY ROUTINE TO WRITE OUT LOWER TRIANGLE OF A SQUARE MATRIX
C
DIMENSION TM(NC,1),T(8),ST(13)
COMMON KI,KO,INDSK,IODSK
CALL OFILE(IODSK,DFLE)
WRITE(IODSK)NC
WRITE(IODSK)T,ST
DO 5 I=2,NC
5 WRITE(IODSK)(TM(I,J),J=1,I-1)
CALL RELEAS (IODSK)
RETURN
END
SUBROUTINE MATWV(RMAT,NR,NC,RT,CT,OVT,ST,ICPT,IRPT)
C
C GENERAL MATRIX PRINTING ROUTINE FUNCTION AS FOR MATWRT
C
C COLUMNS AND ROWS ARE PRINTED IN ORDER SPECIFIED BY ICPT AND IRPT
C 15 ELEMENTS APPEAR IN EACH PAGE ROW
C ELEMENTS ARE IN F7.3 FORM
C 0.000 IS BLANK SUPPRESSED
C
COMMON KI,KO
DIMENSION OVT(8),ROW(27),RMAT(NC,1),HEAD(27)
DIMENSION ICPT(1),IRPT(1)
DIMENSION ST(13)
IPAG=1
IFINFL=.FALSE.
LIML=1
LIMR=15
IF(NC.GT.15)GO TO 2
IFINFL=.TRUE.
LIMR=NC
2 WRITE(KO,5)OVT,IPAG,ST,CT
5 FORMAT(1H1,8A5,' PAGE ',I3,/,1X,13A5,/,15X,A5/)
ENCODE(132,10,HEAD)(ICPT(I),I=LIML,LIMR)
10 FORMAT(12X,15(4X,I3,1X))
WRITE(KO,15)HEAD
15 FORMAT(1X,26A5,A2)
DO 17 I=1,27
17 HEAD(I)=' '
HEAD(3)=' ---'
L=(LIMR-LIML)*8/5
DO 19 I=4,4+L
19 HEAD(I)='-----'
WRITE(KO,20)HEAD,RT
20 FORMAT(1X,26A5,A2,/,'+',A5)
DO 25 J=1,NR
ENCODE(133,30,ROW)IRPT(J),(RMAT(I,J),I= LIML,LIMR)
30 FORMAT(6X,I3,2X,'I ',15(1X,F7.3))
call fixwid(row)
CALL FIXOVF(ROW,15,RMAT(LIML,J),LIML,LIMR)
25 WRITE(KO,35)ROW
35 FORMAT(26A5,A3)
IF(IFINFL)GO TO 50
LIML=LIML+15
LIMR=LIMR+15
IPAG=IPAG+1
IF(LIMR.LT.NC)GO TO 2
IFINFL=.TRUE.
LIMR=NC
GO TO 2
50 WRITE(KO,15)HEAD
RETURN
END
SUBROUTINE MATWRT(RMAT,NR,NC,RT,CT,OVT,ST)
C
C ROUTINE TO PRINT OUT A MATRIX IN EFFICIENT EASILY PIECED TOGETHER
C FORM. EACH ELEMENT APPEARS IN F7.1 FORM - 15 ELEMENTS IN ROW.
C
C RT - A5 ROW TITLE
C CT - A5 COLUMN TITLE
C OVT - 8A5 OVERALL TITLE
C ST - 13A5 SUBTITLE
C
COMMON KI,KO
DIMENSION OVT(8),RMAT(NC,1),HEAD(27),ST(13)
C
C INITIALISE
C
IPAG=1
IFINFL=.FALSE.
LIML=1
LIMR=15
IF(NC.GT.20)GO TO 2
IFINFL=.TRUE.
LIMR=NC
C
C NEW PAGE - WRITE TITLES AND COLUMN HEADS AND UNDERLINES
C
2 WRITE(KO,5)OVT,IPAG,ST,CT
5 FORMAT(1H1,8A5,' PAGE ',I3,/,1X,13A5,//,15X,A5/)
ENCODE(132,10,HEAD)(I,I=LIML,LIMR)
10 FORMAT(12X,15(4X,I3,1X))
WRITE(KO,15)HEAD
15 FORMAT(1X,26A5,A2)
DO 17 I=1,27
17 HEAD(I)=' '
HEAD(3)=' ---'
L=(LIMR-LIML)*8/5
DO 19 I=4,4+L
19 HEAD(I)='-----'
WRITE(KO,20)HEAD,RT
20 FORMAT(1X,26A5,A2,/,'+',A5)
C
C WRITE OUT EACH COLUMN INORDER FOR THIS PAGE DOWN TO MAX ROWS
C
DO 25 J=1,NR
25 WRITE(KO,30)J,(RMAT(I,J),I= LIML,LIMR)
30 FORMAT(6X,I3,2X,'I ',15(1X,F7.1))
C
C TEST IF FINISHED MATRIX
C
IF(IFINFL)GO TO 50
C
C ELSE MOVE TO NEXT GROUP OF COLUMNS
C
LIML=LIML+15
LIMR=LIMR+15
IPAG=IPAG+1
C
C TEST IF THIS FINISHES MATRIX
IF(LIMR.LT.NC)GO TO 2
IFINFL=.TRUE.
LIMR=NC
GO TO 2
C
C FINALLY RETURN IFDONE
C
50 WRITE(KO,15)HEAD
RETURN
END
SUBROUTINE GETVEC(V,N)
C
C UTILITY ROUTINE TO READ ONE LOG RECORD FROM DSK TO A VECTOR
C
DIMENSION V(1)
COMMON KI,KO,IN,IO
C
DO 5 I=1,N
5 READ(IO) V(I)
RETURN
END
SUBROUTINE WDSKA(IARR,N)
C
C UTILITY ROUTINE TO WRITE ONE LOG RECORD TO DSK FROM A VECTOR
C
COMMON IN,IO,INDSK,IODSK
REAL IARR(1)
WRITE(IODSK)(IARR(I),I=1,N)
RETURN
END
SUBROUTINE RCCON(R1,NR,NC,R2)
C
C CONVERTS R1 STORED COL-WISE
C TO R2 STORED ROW WISE
C N.B. NO TRANSPOSITION IS DONE,JUST STORAGE MODE CHANGED.
C
DIMENSION R1(NR,NC),R2(NC,NR)
DO 5 I=1,NR
DO 5 J=1,NC
5 R2(J,I)=R1(I,J)
RETURN
END
SUBROUTINE MULMAT(A,B,C,NRA,NCA,NCB)
C
C MULTIPLIES A(NRA * NCA)
C INTO B(NCA * NCB)
C GIVING C(NRA * NCB)
C
DIMENSION A (NCA,NRA),B(NCB,NCA),C(NCB,NRA)
C
DO 10 I=1,NCB
DO 10 J=1,NRA
SUM=0
DO 5 K=1,NCA
IF(B(I,K).EQ.99999)GO TO 5
SUM=SUM+A(K,J)*B(I,K)
5 CONTINUE
10 C(I,J)=SUM
RETURN
END
SUBROUTINE DELOG(ARR,NR,NC)
C
C DETRANSFORMS LOGGED DATA
C
DIMENSION ARR(NC,1)
DO 5 I=1,NC
DO 5 J=1,NR
IF(ARR(I,J).EQ.99999)GO TO 5
ARR(I,J)=(10.0**ARR(I,J))-1
5 CONTINUE
RETURN
END