diff options
Diffstat (limited to 'Trivac/src/NEIGH1.f')
| -rwxr-xr-x | Trivac/src/NEIGH1.f | 1603 |
1 files changed, 1603 insertions, 0 deletions
diff --git a/Trivac/src/NEIGH1.f b/Trivac/src/NEIGH1.f new file mode 100755 index 0000000..1293bab --- /dev/null +++ b/Trivac/src/NEIGH1.f @@ -0,0 +1,1603 @@ +*DECK NEIGH1 + SUBROUTINE NEIGH1 (NC,N,K,M,POIDS) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute the index of a neighbour hexagon for a given symmetry. +* The following SUBROUTINE points are available: +* NEIGH1: S30 symmetry; NEIGH2: SA60 symmetry; +* NEIGH3: SB60 symmetry; NEIGH4: S90 symmetry; +* NEIGH5: R120 symmetry; NEIGH6: R180 symmetry; +* NEIGH7: SA180 symmetry; NEIGH8: SB180 symmetry; +* NEIGH9: complete assembly; NEIG10: S30 symmetry with HBC SYME; +* NEIG11: SA60 symmetry with HBC SYME. +* +*Copyright: +* Copyright (C) 2002 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): A. Benaboud +* +*Parameters: input +* NC total number of hexagonal crowns. +* N index of the considered hexagon. +* K index of the side. +* POIDS weight of the hexagon. +* +*Parameters: output +* M index of the neighbour hexagon (=n: reflection on side k; +* .LT.0: axial symmetry or rotation). +* +*----------------------------------------------------------------------- +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + FSTA(1) = 1 + IL=0 + DO 1 L = 1,NC+1,2 + NBA(L) = 1+IL + NBA(L+1) = 1+IL + IL = IL+1 + 1 CONTINUE + DO 2 L = 2,NC+1 + FSTA(L) = FSTA(L-1)+NBA(L-1) + 2 CONTINUE + IL=0 + DO 3 L = 1,NC+1,2 + LSTA(L) = FSTA(L)+IL + LSTA(L+1) = FSTA(L+1)+IL + IL = IL+1 + 3 CONTINUE +* + I=1 + IF (N.GT.1) THEN + I=0 + DO 4 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 5 + ENDIF + 4 CONTINUE + 5 IF (I.EQ.0) CALL XABORT('NEIGH1: ALGORITHM FAILURE.') + ENDIF +* + N1 = FSTA(I) + N2 = LSTA(I) + EVEN = MOD(I,2).EQ.0 +* + IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 2 + ELSE IF (EVEN) THEN + M = N+NBA(I)+1 + ELSE IF (.NOT.EVEN) THEN + M = N+NBA(I) + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (N.EQ.N2) THEN + M = -(LSTA(I+1)-1) + ELSE + M = N+1 + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF ((N.EQ.1).OR.(N.EQ.2)) THEN + M = -2 + ELSE IF (N.EQ.N2) THEN + M = -(N-1) + ELSE IF (EVEN) THEN + M = N-NBA(I-1)+1 + ELSE IF (.NOT.EVEN) THEN + M = N-NBA(I-1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -FSTA(I-1) + ELSE IF (EVEN) THEN + M = N-NBA(I-1) + ELSE IF (.NOT.EVEN) THEN + M = N-NBA(I-1)-1 + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = N + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -(N+1) + ELSE + M = N-1 + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -FSTA(I+1) + ELSE IF (EVEN) THEN + M = N+NBA(I) + ELSE IF (.NOT.EVEN) THEN + M = N+NBA(I)-1 + ENDIF +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 1./12. + ELSE IF (N.EQ.N2) THEN + POIDS = 0.5 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + POIDS = 0.5 + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIGH2 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + NBA(1) = 1 + LSTA(1) = 1 + FSTA(1) = 1 + FSTA(2) = 2 + DO 7 L = 2,NC+1 + NBA(L) = L + LSTA(L) = L+LSTA(L-1) + FSTA(L+1) = L+FSTA(L) + 7 CONTINUE +* + I=0 + DO 8 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 9 + ENDIF + 8 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIGH2: ALGORITHM FAILURE.') +* + 9 N1 = FSTA(I) + N2 = LSTA(I) +* + IF (K.EQ.1) THEN +* + M = N+NBA(I)+1 +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.N2) THEN + M = -(N+NBA(I)) + ELSE + M = N+1 + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF (N.EQ.N2) THEN + M = -(N-1) + ELSE + M = N-NBA(I-1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.N1) THEN + M = -(N+1) + ELSE + M = N-NBA(I-1)-1 + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.N1) THEN + M = -(N+NBA(I)+1) + ELSE + M = N-1 + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + M = N+NBA(I) +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 1./6. + ELSE IF ((N.EQ.N1).OR.(N.EQ.N2)) THEN + POIDS = 0.5 + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIGH3 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + LSTA(1) = 1 + FSTA(1) = 1 + IL=0 + DO 10 L = 1,NC+1,2 + NBA(L) = 1+IL + NBA(L+1) = 1+IL + IL = IL+2 + 10 CONTINUE + DO 11 L = 2,NC+1 + FSTA(L) = FSTA(L-1)+NBA(L-1) + LSTA(L) = NBA(L)+LSTA(L-1) + 11 CONTINUE +* + I=0 + N1=0 + N2=0 + N3=0 + IF (N.EQ.1) GOTO 14 + DO 12 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 13 + ENDIF + 12 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIGH3: ALGORITHM FAILURE.') +* + 13 N1 = FSTA(I) + N2 = (FSTA(I)+LSTA(I))/2 + N3 = LSTA(I) + EVEN = MOD(I,2).EQ.0 +* + 14 IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 2 + ELSE IF ((N.GE.N1).AND.(N.LE.N3)) THEN + M = N+I + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (N.EQ.2) THEN + M = 5 + ELSE IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N+1 + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+I+1 + ELSE IF ((N.EQ.N3).AND.EVEN) THEN + M = LSTA(I+1) + ELSE IF ((N.EQ.N3).AND.(.NOT.EVEN)) THEN + M = -LSTA(I+1) + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (N.EQ.2) THEN + M = 2 + ELSE IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N+2-I + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+1 + ELSE IF ((N.EQ.N3).AND.EVEN) THEN + M = N + ELSE IF ((N.EQ.N3).AND.(.NOT.EVEN)) THEN + M = -(N-1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = N+1-I + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -(N+2-I) + ELSE IF ((N.GT.N1).AND.(N.LT.N3)) THEN + M = N+1-I + ELSE IF ((N.EQ.N3).AND.EVEN) THEN + M = N+1-I + ELSE IF ((N.EQ.N3).AND.(.NOT.EVEN)) THEN + M = -(N-I) + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = N + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -(N+1) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N-1 + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-I + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = N+I-1 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -(N+I) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N+I-1 + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-1 + ENDIF +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 1./6. + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + POIDS = 0.5 + ELSE IF ((N.EQ.N3).AND.(.NOT.EVEN)) THEN + POIDS = 0.5 + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIGH4 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA,INTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2),INTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + INTA(:NC+2)=0 + LSTA(1) = 1 + FSTA(1) = 1 + IL=0 + DO 15 L = 1,NC+1,2 + NBA(L) = L+IL + NBA(L+1) = L+1+IL + IL = IL+1 + 15 CONTINUE + DO 16 L = 2,NC+1 + FSTA(L) = FSTA(L-1)+NBA(L-1) + LSTA(L) = NBA(L)+LSTA(L-1) + 16 CONTINUE + IL=0 + DO 17 L = 1,NC+1,2 + INTA(L) = FSTA(L)+IL + INTA(L+1) = FSTA(L+1)+IL + IL = IL+1 + 17 CONTINUE +* + I=0 + N1=0 + N2=0 + N3=0 + IF (N.EQ.1) GOTO 20 + DO 18 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 19 + ENDIF + 18 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIGH4: ALGORITHM FAILURE.') +* + 19 N1 = FSTA(I) + N2 = INTA(I) + N3 = LSTA(I) + EVEN = MOD(I,2).EQ.0 +* + 20 IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 2 + ELSE IF ((N.GE.N1).AND.(N.LE.N3).AND.EVEN) THEN + M = N+NBA(I)+1 + ELSE IF ((N.GE.N1).AND.(N.LE.N3).AND.(.NOT.EVEN)) THEN + M = N+NBA(I) + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = 3 + ELSE IF (N.EQ.2) THEN + M = 6 + ELSE IF (N.EQ.N1) THEN + M = N+1 + ELSE IF ((N.GT.N1).AND.(N.LT.N2)) THEN + M = N+1 + ELSE IF ((N.GE.N2).AND.(N.LE.N3)) THEN + M = N+NBA(I+1) + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (N.EQ.2) THEN + M = 3 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = FSTA(I-1)+1 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = FSTA(I-1) + ELSE IF ((N.GT.N1).AND.(N.LT.N2).AND.EVEN) THEN + M = N-(I-1)-(INTA(I-1)-FSTA(I-1))+1 + ELSE IF ((N.GT.N1).AND.(N.LT.N2).AND.(.NOT.EVEN)) THEN + M = N-(I-1)-(INTA(I-1)-FSTA(I-1)) + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+1 + ELSE IF (N.EQ.N3) THEN + M = -(LSTA(I+1)-1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = FSTA(I-1) + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -FSTA(I-1) + ELSE IF ((N.GT.N1).AND.(N.LT.N3).AND.EVEN) THEN + M = N-NBA(I-1) + ELSE IF ((N.GT.N1).AND.(N.LT.N3).AND.(.NOT.EVEN)) THEN + M = N-NBA(I-1)-1 + ELSE IF (N.EQ.N3) THEN + M = -(N-1) + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = N + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -(N+1) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N-1 + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-NBA(I) + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = FSTA(I+1) + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -FSTA(I+1) + ELSE IF ((N.GT.N1).AND.(N.LT.N2).AND.EVEN) THEN + M = N+I+INTA(I)-FSTA(I) + ELSE IF ((N.GT.N1).AND.(N.LT.N2).AND.(.NOT.EVEN)) THEN + M = N+I+INTA(I)-FSTA(I)-1 + ELSE IF (N.EQ.N2) THEN + M = INTA(I+1)-1 + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-1 + ENDIF +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 0.25 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + POIDS = 0.5 + ELSE IF (N.EQ.N3) THEN + POIDS = 0.5 + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA,INTA) + RETURN + END +* + SUBROUTINE NEIGH5 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + NBA (1) = 1 + LSTA(1) = 1 + FSTA(1) = 1 + DO 21 L = 2,NC+1 + NBA(L) = 2*(L-1) + LSTA(L) = NBA(L)+LSTA(L-1) + FSTA(L) = NBA(L-1)+FSTA(L-1) + 21 CONTINUE +* + I=0 + DO 22 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 23 + ENDIF + 22 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIGH5: ALGORITHM FAILURE.') +* + 23 N1 = FSTA(I) + N2 = FSTA(I) + (I-2) + N3 = LSTA(I) +* + IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 2 + ELSE IF ((N.GE.N1).AND.(N.LT.N2).AND.(N.NE.1)) THEN + M = N+NBA(I+1)-1 + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+NBA(I)+1 + ELSE IF (N.EQ.N3) THEN + M = N+NBA(I+1)-1 + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = 3 + ELSE IF (N.EQ.2) THEN + M = 6 + ELSE IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N+1 + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+NBA(I)+2 + ELSE IF (N.EQ.N3) THEN + M = N+NBA(I+1) + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (N.EQ.2) THEN + M = 3 + ELSE IF ((N.GE.N1).AND.(N.LT.N2).AND.(N.NE.1)) THEN + M = N-NBA(I-1) + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+1 + ELSE IF (N.EQ.N3) THEN + M = -(N+1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF (N.EQ.2) THEN + M = 1 + ELSE IF (N.EQ.3) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.(N.NE.1)) THEN + M = -LSTA(I-1) + ELSE IF ((N.GT.N1).AND.(N.LT.N3)) THEN + M = N-NBA(I-1)-1 + ELSE IF ((N.EQ.N3).AND.(N.NE.3)) THEN + M = -(N-NBA(I-1)-1) + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (N.EQ.2) THEN + M = -3 + ELSE IF ((N.EQ.N1).AND.(N.NE.1)) THEN + M = -LSTA(I) + ELSE IF ((N.GT.N1).AND.(N.LE.N2).AND.(N.NE.3)) THEN + M = N-1 + ELSE IF ((N.GT.N2).AND.(N.LT.N3)) THEN + M = N-NBA(I-1)-2 + ELSE IF (N.EQ.N3) THEN + M = N-NBA(I) + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF (N.EQ.3) THEN + M = 2 + ELSE IF ((N.EQ.N1).AND.(N.NE.1)) THEN + M = FSTA(I+1) + ELSE IF ((N.GT.N1).AND.(N.LT.N2)) THEN + M = N+NBA(I+1)-2 + ELSE IF (N.EQ.N2) THEN + M = N+NBA(I) + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-1 + ENDIF +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 1./3. + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIGH6 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + NBA (1) = 1 + LSTA(1) = 1 + FSTA(1) = 1 + DO 24 L = 2,NC+1 + NBA(L) = 3*(L-1) + LSTA(L) = NBA(L)+LSTA(L-1) + FSTA(L) = NBA(L-1)+FSTA(L-1) + 24 CONTINUE +* + I=0 + N1=0 + N2=0 + N3=0 + N4=0 + IF (N.EQ.1) GOTO 27 + DO 25 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 26 + ENDIF + 25 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIGH6: ALGORITHM FAILURE.') +* + 26 N1 = FSTA(I) + N2 = LSTA(I-1) + (I-1) + N3 = LSTA(I-1) + 2*(I-1) + N4 = LSTA(I) +* + 27 IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 3 + ELSE IF (N.EQ.2) THEN + M = 7 + ELSE IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N+1 + ELSE IF ((N.GE.N2).AND.(N.LE.N4)) THEN + M = N+NBA(I)+2 + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = 4 + ELSE IF (N.EQ.2) THEN + M = 3 + ELSE IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N-NBA(I-1) + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+1 + ELSE IF ((N.GE.N3).AND.(N.LE.N4)) THEN + M = N+NBA(I+1) + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (N.EQ.2) THEN + M = 1 + ELSE IF (N.EQ.N1) THEN + M = -(N-1) + ELSE IF ((N.GT.N1).AND.(N.LT.N3)) THEN + M = N-NBA(I-1)-1 + ELSE IF ((N.GE.N3).AND.(N.LT.N4)) THEN + M = N+1 + ELSE IF (N.EQ.N4) THEN + M = -(N+1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF (N.EQ.2) THEN + M = -4 + ELSE IF (N.EQ.3) THEN + M = 1 + ELSE IF (N.EQ.N1) THEN + M = -LSTA(I) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N-1 + ELSE IF ((N.GT.N2).AND.(N.LT.N4)) THEN + M = N-NBA(I)+1 + ELSE IF (N.EQ.N4) THEN + M = -(N-NBA(I)+1) + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.1) THEN + M = -4 + ELSE IF (N.EQ.3) THEN + M = 2 + ELSE IF ((N.GE.N1).AND.(N.LE.N2)) THEN + M = N+NBA(I) + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-1 + ELSE IF ((N.GT.N3).AND.(N.LE.N4)) THEN + M = N-NBA(I) + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.1) THEN + M = 2 + ELSE IF ((N.GE.N1).AND.(N.LE.N3)) THEN + M = N+NBA(I)+1 + ELSE IF ((N.GT.N3).AND.(N.LE.N4)) THEN + M = N-1 + ENDIF +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 1./2. + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIGH7 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + NBA (1) = 1 + LSTA(1) = 1 + FSTA(1) = 1 + DO 28 L = 2,NC+1 + NBA(L) = 3+NBA(L-1) + LSTA(L) = NBA(L)+LSTA(L-1) + FSTA(L) = 1+LSTA(L-1) + 28 CONTINUE +* + I=0 + DO 29 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 30 + ENDIF + 29 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIGH7: ALGORITHM FAILURE.') +* + 30 N1 = FSTA(I) + N2 = FSTA(I) + (I-1) + N3 = FSTA(I) + 2*(I-1) + N4 = LSTA(I) +* + IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 4 + ELSE IF ((N.GE.N1).AND.(N.LT.N2).AND.(N.NE.1)) THEN + M = N+1 + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = NBA(I)+N+2 + ELSE IF ((N.GE.N3).AND.(N.LE.N4)) THEN + M = NBA(I+1)+N-1 + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = 5 + ELSE IF ((N.GE.N1).AND.(N.LT.N2).AND.(N.NE.1)) THEN + M = N-NBA(I-1) + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+1 + ELSE IF ((N.GE.N3).AND.(N.LE.N4)) THEN + M = N+NBA(I+1) + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF (N.EQ.1) THEN + M = -4 + ELSE IF ((N.EQ.N1).AND.(N.NE.1)) THEN + M = -(N+1) + ELSE IF ((N.GT.N1).AND.(N.LT.N3)) THEN + M = N-NBA(I-1)-1 + ELSE IF ((N.GE.N3).AND.(N.LT.N4)) THEN + M = N+1 + ELSE IF (N.EQ.N4) THEN + M = -(N+NBA(I+1)-1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF ((N.EQ.N1).AND.(N.NE.1)) THEN + M = -(FSTA(I+1)+1) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N-1 + ELSE IF ((N.GT.N2).AND.(N.LT.N3)) THEN + M = N-NBA(I-1)-2 + ELSE IF ((N.GE.N3).AND.(N.LT.N4)) THEN + M = N-NBA(I)+1 + ELSE IF (N.EQ.N4) THEN + M = -(N-1) + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.N1) THEN + M = FSTA(I+1) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N+NBA(I) + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-1 + ELSE IF ((N.GT.N3).AND.(N.LE.N4)) THEN + M = N-NBA(I) + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.N1) THEN + M = FSTA(I+1)+1 + ELSE IF ((N.GT.N1).AND.(N.LT.N3)) THEN + M = N+NBA(I)+1 + ELSE IF (N.EQ.N3) THEN + M = N+NBA(I+1)-2 + ELSE IF ((N.GT.N3).AND.(N.LE.N4)) THEN + M = N-1 + ENDIF +* + ENDIF +* + IF ((N.EQ.N1).OR.(N.EQ.N4)) THEN + POIDS = 0.5 + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIGH8 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + NBA (1) = 1 + LSTA(1) = 1 + FSTA(1) = 1 + DO 31 L = 2,NC+1,2 + NBA(L) = 3*(L-1) + NBA(L+1) = 3*L+1 + 31 CONTINUE + DO 32 L = 2,NC+1 + LSTA(L) = NBA(L)+LSTA(L-1) + FSTA(L) = NBA(L-1)+FSTA(L-1) + 32 CONTINUE +* + I=0 + N1=0 + N2=0 + N3=0 + N4=0 + N5=0 + IF (N.EQ.1) GOTO 35 + DO 33 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 34 + ENDIF + 33 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIGH8: ALGORITHM FAILURE.') +* + 34 N1 = FSTA(I) + N2 = (FSTA(I) + LSTA(I))/2 - (I-1) + N3 = (FSTA(I) + LSTA(I))/2 + N4 = (FSTA(I) + LSTA(I))/2 + (I-1) + N5 = LSTA(I) + EVEN = MOD(I,2).EQ.0 +* + 35 IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 2 + ELSE IF ((N.GE.N1).AND.(N.LE.N3)) THEN + M = N+3*I-2 + ELSE IF ((N.GT.N3).AND.(N.LE.N4)) THEN + M = N-1 + ELSE IF ((N.GT.N4).AND.(N.LE.N5)) THEN + M = N-(3*I-2) + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = 3 + ELSE IF (N.EQ.2) THEN + M = 7 + ELSE IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N+1 + ELSE IF ((N.GE.N2).AND.(N.LE.N4)) THEN + M = N+3*I-1 + ELSE IF ((N.GT.N4).AND.(N.LE.N5)) THEN + M = N-1 + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF (N.EQ.1) THEN + M = 4 + ELSE IF (N.EQ.2) THEN + M = 3 + ELSE IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N-3*(I-2) + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+1 + ELSE IF ((N.GE.N3).AND.(N.LE.N5)) THEN + M = N+3*I + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -4 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = FSTA(I-1) + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -FSTA(I-1) + ELSE IF ((N.GT.N1).AND.(N.LT.N3)) THEN + M = N-3*I+5 + ELSE IF ((N.GE.N3).AND.(N.LT.N4)) THEN + M = N+1 + ELSE IF ((N.GE.N4).AND.(N.LT.N5)) THEN + M = N+3*I+1 + ELSE IF ((N.EQ.N5).AND.EVEN) THEN + M = LSTA(I+1) + ELSE IF ((N.EQ.N5).AND.(.NOT.EVEN)) THEN + M = -LSTA(I+1) + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = N + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -(N+1) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N-1 + ELSE IF ((N.GT.N2).AND.(N.LT.N4)) THEN + M = N-3*I+4 + ELSE IF ((N.GE.N4).AND.(N.LT.N5)) THEN + M = N+1 + ELSE IF ((N.EQ.N5).AND.EVEN) THEN + M = N + ELSE IF ((N.EQ.N5).AND.(.NOT.EVEN)) THEN + M = -(N-1) + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = FSTA(I+1) + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -FSTA(I+1) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N+3*(I-1) + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-1 + ELSE IF ((N.GT.N3).AND.(N.LT.N5)) THEN + M = N-3*(I-1) + ELSE IF ((N.EQ.N5).AND.EVEN) THEN + M = LSTA(I-1) + ELSE IF ((N.EQ.N5).AND.(.NOT.EVEN)) THEN + M = -LSTA(I-1) + ENDIF +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 0.5 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + POIDS = 0.5 + ELSE IF ((N.EQ.N5).AND.(.NOT.EVEN)) THEN + POIDS = 0.5 + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIGH9 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + POIDS = 1. + NBA(1) = 1 + LSTA(1) = 1 + FSTA(1) = 1 + DO 36 L = 2,NC+1 + NBA(L) = (L-1)*6 + LSTA(L) = 1+3*L*(L-1) + FSTA(L) = 1+LSTA(L-1) + 36 CONTINUE +* + I=0 + IF (N.EQ.1) THEN + M = K+1 + RETURN + ELSE IF(N.GT.1) THEN + DO 37 I0 = 2,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 38 + ENDIF + 37 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIGH9: ALGORITHM FAILURE.') + ENDIF +* + 38 N1 = FSTA(I) + N2 = FSTA(I) + (I-1) + N3 = FSTA(I) + 2*(I-1) + N4 = FSTA(I) + 3*(I-1) + N5 = FSTA(I) + 4*(I-1) + N6 = FSTA(I) + 5*(I-1) + N7 = LSTA(I) +* + IF (K.EQ.1) THEN +* + IF (N.EQ.N1) THEN + M = FSTA(I+1) + ELSE IF ((N.GT.N1).AND.(N.LT.N2)) THEN + M = N+NBA(I) + ELSE IF (N.EQ.N2) THEN + M = FSTA(I+1)+I-1 + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N-1 + ELSE IF ((N.GT.N3).AND.(N.LT.N4)) THEN + M = N-NBA(I-1)-3 + ELSE IF (N.EQ.5) THEN + M = 1 + ELSE IF (N.EQ.N4) THEN + M = FSTA(I-1)+3*(I-2) + ELSE IF ((N.GT.N4).AND.(N.LT.N5)) THEN + M = N-NBA(I-1)-3 + ELSE IF ((N.GE.N5).AND.(N.LT.N6)) THEN + M = N+1 + ELSE IF (N.EQ.7) THEN + M = 19 + ELSE IF ((N.GE.N6).AND.(N.LE.N7)) THEN + M = N+NBA(I)+6 + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.N1) THEN + M = FSTA(I+1)+1 + ELSE IF ((N.GT.N1).AND.(N.LT.N2)) THEN + M = N+NBA(I)+1 + ELSE IF (N.EQ.N2) THEN + M = FSTA(I+1)+I + ELSE IF ((N.GT.N2).AND.(N.LE.N3)) THEN + M = N+NBA(I)+1 + ELSE IF ((N.GT.N3).AND.(N.LE.N4)) THEN + M = N-1 + ELSE IF ((N.GT.N4).AND.(N.LT.N5)) THEN + M = N-NBA(I-1)-4 + ELSE IF (N.EQ.6) THEN + M = 1 + ELSE IF (N.EQ.N5) THEN + M = FSTA(I-1)+4*(I-2) + ELSE IF ((N.GT.N5).AND.(N.LT.N6)) THEN + M = N-NBA(I-1)-4 + ELSE IF ((N.GE.N6).AND.(N.LT.N7)) THEN + M = N+1 + ELSE IF (N.EQ.N7) THEN + M = FSTA(I) + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N+1 + ELSE IF (N.EQ.N2) THEN + M = FSTA(I+1)+I+1 + ELSE IF ((N.GT.N2).AND.(N.LE.N4)) THEN + M = N+NBA(I)+2 + ELSE IF ((N.GT.N4).AND.(N.LE.N5)) THEN + M = N-1 + ELSE IF (N.EQ.7) THEN + M = 1 + ELSE IF ((N.GT.N5).AND.(N.LT.N7)) THEN + M = N-NBA(I-1)-5 + ELSE IF (N.EQ.N7) THEN + M = FSTA(I-1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.2) THEN + M = 1 + ELSE IF ((N.GE.N1).AND.(N.LT.N2)) THEN + M = N-NBA(I-1) + ELSE IF ((N.GE.N2).AND.(N.LT.N3)) THEN + M = N+1 + ELSE IF ((N.GE.N3).AND.(N.LE.N5)) THEN + M = N+NBA(I)+3 + ELSE IF ((N.GT.N5).AND.(N.LE.N6)) THEN + M = N-1 + ELSE IF ((N.GT.N6).AND.(N.LT.N7)) THEN + M = N-NBA(I-1)-6 + ELSE IF (N.EQ.N7) THEN + M = LSTA(I-1) + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.N1) THEN + M = LSTA(I) + ELSE IF (N.EQ.3) THEN + M = 1 + ELSE IF (N.EQ.7) THEN + M = 17 + ELSE IF ((N.GT.N1).AND.(N.LT.N3)) THEN + M = N-NBA(I-1)-1 + ELSE IF ((N.GE.N3).AND.(N.LT.N4)) THEN + M = N+1 + ELSE IF ((N.GE.N4).AND.(N.LE.N6)) THEN + M = N+NBA(I)+4 + ELSE IF ((N.GT.N6).AND.(N.LE.N7)) THEN + M = N-1 + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.N1) THEN + M = LSTA(I+1) + ELSE IF ((N.GT.N1).AND.(N.LE.N2)) THEN + M = N-1 + ELSE IF ((N.GT.N2).AND.(N.LT.N4)) THEN + M = N-NBA(I-1)-2 + ELSE IF ((N.GE.N4).AND.(N.LT.N5)) THEN + M = N+1 + ELSE IF ((N.GE.N5).AND.(N.LE.N7)) THEN + M = N+NBA(I)+5 + ENDIF + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIG10 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN,OUTER + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + FSTA(1) = 1 + IL=0 + DO 39 L = 1,NC+1,2 + NBA(L) = 1+IL + NBA(L+1) = 1+IL + IL = IL+1 + 39 CONTINUE + DO 40 L = 2,NC+1 + FSTA(L) = FSTA(L-1)+NBA(L-1) + 40 CONTINUE + IL=0 + DO 41 L = 1,NC+1,2 + LSTA(L) = FSTA(L)+IL + LSTA(L+1) = FSTA(L+1)+IL + IL = IL+1 + 41 CONTINUE +* + I=1 + IF (N.GT.1) THEN + I=0 + DO 42 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 43 + ENDIF + 42 CONTINUE + 43 IF (I.EQ.0) CALL XABORT('NEIG10: ALGORITHM FAILURE.') + ENDIF +* + N1 = FSTA(I) + N2 = LSTA(I) + EVEN = MOD(I,2).EQ.0 + OUTER = I.EQ.NC +* + IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 2 + ELSE IF (OUTER.AND.(N.EQ.2)) THEN + M = -2 + ELSE IF (OUTER.AND.(N.EQ.N2)) THEN + M = -(N-1) + ELSE IF (OUTER.AND.EVEN) THEN + M = -(N-NBA(I-1)+1) + ELSE IF (OUTER.AND.(.NOT.EVEN)) THEN + M = -(N-NBA(I-1)) + ELSE IF (EVEN) THEN + M = N+NBA(I)+1 + ELSE IF (.NOT.EVEN) THEN + M = N+NBA(I) + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (OUTER.AND.(N.EQ.N2)) THEN + M = -LSTA(I-1) + ELSE IF (N.EQ.N2) THEN + M = -(LSTA(I+1)-1) + ELSE + M = N+1 + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF ((N.EQ.1).OR.(N.EQ.2)) THEN + M = -2 + ELSE IF (N.EQ.N2) THEN + M = -(N-1) + ELSE IF (EVEN) THEN + M = N-NBA(I-1)+1 + ELSE IF (.NOT.EVEN) THEN + M = N-NBA(I-1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -FSTA(I-1) + ELSE IF (EVEN) THEN + M = N-NBA(I-1) + ELSE IF (.NOT.EVEN) THEN + M = N-NBA(I-1)-1 + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF ((N.EQ.N1).AND.EVEN) THEN + M = N + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -(N+1) + ELSE + M = N-1 + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (OUTER.AND.(N.EQ.N1)) THEN + M = -FSTA(I-1) + ELSE IF (OUTER.AND.EVEN) THEN + M = -(N-NBA(I-1)) + ELSE IF (OUTER.AND.(.NOT.EVEN)) THEN + M = -(N-NBA(I-1)-1) + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + M = -FSTA(I+1) + ELSE IF (EVEN) THEN + M = N+NBA(I) + ELSE IF (.NOT.EVEN) THEN + M = N+NBA(I)-1 + ENDIF +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 1./12. + ELSE IF (OUTER.AND.(N.EQ.N2)) THEN + POIDS = 1./6. + ELSE IF (OUTER.AND.(N.EQ.N1).AND.(.NOT.EVEN)) THEN + POIDS = 0.25 + ELSE IF (OUTER.OR.(N.EQ.N2)) THEN + POIDS = 0.5 + ELSE IF ((N.EQ.N1).AND.(.NOT.EVEN)) THEN + POIDS = 0.5 + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END +* + SUBROUTINE NEIG11 (NC,N,K,M,POIDS) +* +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NC,N,K,M + REAL POIDS +*---- +* LOCAL VARIABLES +*---- + LOGICAL EVEN,OUTER + INTEGER, DIMENSION(:), ALLOCATABLE :: NBA,FSTA,LSTA +* + ALLOCATE(NBA(NC+2),FSTA(NC+2),LSTA(NC+2)) + EVEN=.TRUE. + NBA(:NC+2)=0 + FSTA(:NC+2)=0 + LSTA(:NC+2)=0 + NBA(1) = 1 + LSTA(1) = 1 + FSTA(1) = 1 + FSTA(2) = 2 + DO 45 L = 2,NC+1 + NBA(L) = L + LSTA(L) = L+LSTA(L-1) + FSTA(L+1) = L+FSTA(L) + 45 CONTINUE +* + I=0 + DO 46 I0 = 1,NC + IF ((N.GE.FSTA(I0)).AND.(N.LE.LSTA(I0))) THEN + I=I0 + GO TO 47 + ENDIF + 46 CONTINUE + IF (I.EQ.0) CALL XABORT('NEIG11: ALGORITHM FAILURE.') +* + 47 N1 = FSTA(I) + N2 = LSTA(I) + OUTER = I.EQ.NC +* + IF (K.EQ.1) THEN +* + IF (N.EQ.1) THEN + M = 3 + ELSE IF (OUTER.AND.(N.EQ.N2)) THEN + M = -(N-1) + ELSE IF (OUTER) THEN + M = -(N-NBA(I-1)) + ELSE + M = N+NBA(I)+1 + ENDIF +* + ELSE IF (K.EQ.2) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (OUTER.AND.(N.EQ.N2)) THEN + M = -(N-NBA(I-1)-1) + ELSE IF (N.EQ.N2) THEN + M = -(N+NBA(I)) + ELSE + M = N+1 + ENDIF +* + ELSE IF (K.EQ.3) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF (N.EQ.N2) THEN + M = -(N-1) + ELSE + M = N-NBA(I-1) + ENDIF +* + ELSE IF (K.EQ.4) THEN +* + IF (N.EQ.1) THEN + M = -2 + ELSE IF (N.EQ.N1) THEN + M = -(N+1) + ELSE + M = N-NBA(I-1)-1 + ENDIF +* + ELSE IF (K.EQ.5) THEN +* + IF (N.EQ.1) THEN + M = -3 + ELSE IF (OUTER.AND.(N.EQ.N1)) THEN + M = -(N-NBA(I-1)) + ELSE IF (N.EQ.N1) THEN + M = -(N+NBA(I)+1) + ELSE + M = N-1 + ENDIF +* + ELSE IF (K.EQ.6) THEN +* + IF (N.EQ.1) THEN + M = 2 + ELSE IF (OUTER.AND.(N.EQ.N1)) THEN + M = -(N+1) + ELSE IF (OUTER) THEN + M = -(N-NBA(I-1)-1) + ELSE + M = N+NBA(I) + ENDIF +* + ENDIF +* + IF (N.EQ.1) THEN + POIDS = 1./6. + ELSE IF (OUTER.AND.((N.EQ.N1).OR.(N.EQ.N2))) THEN + POIDS = 1./6. + ELSE IF (OUTER.OR.(N.EQ.N1).OR.(N.EQ.N2)) THEN + POIDS = 0.5 + ELSE + POIDS = 1. + ENDIF + DEALLOCATE(NBA,FSTA,LSTA) + RETURN + END |