Google
 

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