Initial commit from Polytechnique Montreal

1 files changed, 875 insertions, 0 deletions

diff --git a/Dragon/src/NXTCUA.f b/Dragon/src/NXTCUA.f
new file mode 100644
index 0000000..8d62236
--- /dev/null
+++ b/Dragon/src/NXTCUA.f
@@ -0,0 +1,875 @@
+*DECK NXTCUA
+      SUBROUTINE NXTCUA(IPRINT,NDIM  ,IDIAG ,ISAXIS,
+     >                  NBOCEL,NBUCEL,NOCELL,NUCELL,
+     >                  ITSYM ,IDFEX ,IDFRT ,IUNFLD)
+*
+*----------
+*
+*Purpose:
+* To create the array for testing the geometry in
+* a Cartesian assembly for internal symmetries and unfolding
+* the assembly according to the symmetries.
+*
+*Copyright:
+* Copyright (C) 2005 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):
+* G. Marleau.
+*
+*Parameters: input
+* IPRINT  print level.
+* NDIM    problem dimensions.
+* IDIAG   the diagonal symmetry flag where:
+*         =-1 indicates X- Y+ DIAG symmetry;
+*         = 1 indicates X+ Y- DIAG symmetry;
+*         = 0 indicates no DIAG symmetry.
+* ISAXIS  symmetry vector for each direction.
+* NBOCEL  number of cells in original geometry.
+* NBUCEL  number of cells in unfolded geometry.
+* NOCELL  number of cell before unfolding in
+*         $X$, $Y$ and $Z$ directions.
+* NUCELL  number of cell after unfolding in
+*         $X$, $Y$ and $Z$ directions.
+*
+*Parameters: output
+* ITSYM   array to identify the symmetry to test for each original
+*         cell where:
+*         ITSYM(1,*) identify $X$ symmetry;
+*         ITSYM(2,*) identify $Y$ symmetry;
+*         ITSYM(3,*) identify $Z$ symmetry;
+*         ITSYM(4,*) identify $X-Y$ symmetry.
+*         A value of 0 indicate that the geometry does not need
+*         to be verified while a value of 1 implies a verification
+*         of the geometry.
+* IDFEX   identify faces associated with external boundary for a
+*         generating cell and number of times this cell is used. Here:
+*         IDFEX( 1,*)  identify bottom $X$ hexagonal face;
+*         IDFEX( 2,*)  identify top $X$ hexagonal face;
+*         IDFEX( 3,*)  identify bottom $Y$ hexagonal face;
+*         IDFEX( 4,*)  identify top $Y$ hexagonal face;
+*         IDFEX( 5,*)  identify bottom $Z$ face;
+*         IDFEX( 6,*)  identify top $Z$ face;
+*         IDFEX( 7,*)  not used;
+*         IDFEX( 8,*)  not used;
+*         IDFEX( 9,*)  not used;
+*         IDFEX(10,*)  not used.
+* IDFRT   identify reflection/transmission faces.
+* IUNFLD  array to identify the generating cell (IUNFLD(1,*))
+*         and the rotation associated with this region in space.
+*
+*Reference:
+*  G. Marleau,
+*  New Geometries Processing in DRAGON: The NXT: Module,
+*  Report IGE-260, Polytechnique Montreal,
+*  Montreal, 2005.
+*
+*----------
+*
+      IMPLICIT         NONE
+*----
+*  Subroutine arguments
+*----
+      INTEGER          IPRINT,NDIM,IDIAG,ISAXIS(3)
+      INTEGER          NBUCEL,NOCELL(3),NUCELL(3)
+      INTEGER          NBOCEL,ITSYM(4,NBOCEL),IDFEX(0:10,NBOCEL),
+     >                 IDFRT(8,NBOCEL),IUNFLD(2,NBUCEL)
+*----
+*  Local parameters
+*----
+      INTEGER          IOUT
+      CHARACTER        NAMSBR*6
+      PARAMETER       (IOUT=6,NAMSBR='NXTCUA')
+*----
+*  Functions
+*----
+      INTEGER          NXTTRS
+*----
+*  Local variables
+*----
+      INTEGER          IDIR,NSCELL(3),NFCELL(3),
+     >                 NSUC(3),
+     >                 IGEN,IGENT,IX,IY,IZ,ILOCD,
+     >                 ILOCR,IOFYZ,IOFYZR,IOFZ,IOFZR
+*----
+*  Data
+*----
+      CHARACTER*2      CTRN(24)
+      SAVE             CTRN
+      DATA             CTRN
+     > /'+A','+B','+C','+D','+E','+F','+G','+H','+I','+J','+K','+L',
+     >  '-A','-B','-C','-D','-E','-F','-G','-H','-I','-J','-K','-L'/
+*----
+*  Processing starts:
+*  print routine opening header if required
+*  and initialize various parameters.
+*----
+      IF(IPRINT .GE. 10) THEN
+        WRITE(IOUT,6000) NAMSBR
+      ENDIF
+      IDFEX(0:10,:NBOCEL)=0
+      IDFRT(:8,:NBOCEL)=0
+      ITSYM(:4,:NBOCEL)=0
+*----
+*  Prepare direction control vector for
+*  original assembly
+*----
+      DO IDIR=1,3
+        NSCELL(IDIR)=MAX(1,NOCELL(IDIR))
+        NSUC(IDIR)=MAX(1,NUCELL(IDIR))
+        IF(ISAXIS(IDIR) .EQ. -2) THEN
+          NFCELL(IDIR)=NOCELL(IDIR)
+        ELSE IF(ISAXIS(IDIR) .EQ. -1) THEN
+          NFCELL(IDIR)=NOCELL(IDIR)-1
+        ELSE
+          NFCELL(IDIR)=0
+        ENDIF
+*        WRITE(6,*) 'NSCELL =',IDIR,NSCELL(IDIR),NFCELL(IDIR)
+      ENDDO
+*----
+*  Position original cell and process diagonal
+*  symmetry
+*----
+      IGEN=0
+      IF(IDIAG .EQ. -1) THEN
+*----
+*  Process X- Y+ diagonal symmetry
+*----
+        DO IZ=0,NSCELL(3)-1
+          IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+          DO IY=0,NSCELL(2)-1
+            IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+            IX=IY
+            IGEN=IGEN+1
+            IF(IGEN .GT. NBOCEL) CALL XABORT(NAMSBR//
+     >      ': Cell number exceeds number of cells permitted')
+            ILOCD=IOFYZ+IX+NFCELL(1)+1
+            IUNFLD(1,ILOCD)=IGEN
+            IUNFLD(2,ILOCD)=1
+            ITSYM(4,IGEN)=IDIAG
+            DO IX=IY+1,NSCELL(1)-1
+              IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+              IOFYZR=(IX+NFCELL(2)+IOFZ)*NUCELL(1)
+              IGEN=IGEN+1
+              IF(IGEN .GT. NBOCEL) CALL XABORT(NAMSBR//
+     >        ': Cell number exceeds number of cells permitted')
+              ILOCD=IOFYZ+IX+NFCELL(1)+1
+              ILOCR=IOFYZR+IY+NFCELL(1)+1
+              IUNFLD(1,ILOCD)=IGEN
+              IUNFLD(2,ILOCD)=1
+              IUNFLD(1,ILOCR)=IGEN
+              IUNFLD(2,ILOCR)=NXTTRS(1,2)
+            ENDDO
+          ENDDO
+        ENDDO
+*----
+*  Identify cells to tests for X
+*  reflection symmetry
+*----
+        IF(ISAXIS(1) .EQ. 1) THEN
+          IX=NSCELL(1)-1
+          DO IZ=0,NSCELL(3)-1
+            IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+            DO IY=0,NSCELL(2)-1
+              IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+              ILOCD=IOFYZ+IX+NFCELL(1)+1
+              IGEN=IUNFLD(1,ILOCD)
+              ITSYM(1,IGEN)=ISAXIS(1)
+            ENDDO
+          ENDDO
+        ENDIF
+*----
+*  Identify cells to tests for Y
+*  reflection symmetry
+*----
+        IF(ISAXIS(2) .EQ. -1) THEN
+          IY=0
+          DO IZ=0,NSCELL(3)-1
+            IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+            IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+            DO IX=0,NSCELL(1)-1
+              ILOCD=IOFYZ+IX+NFCELL(1)+1
+              IGEN=IUNFLD(1,ILOCD)
+              ITSYM(2,IGEN)=ISAXIS(2)
+            ENDDO
+          ENDDO
+        ENDIF
+*----
+*  Identify cells to tests for Z
+*  reflection symmetry
+*----
+        IF(ABS(ISAXIS(3)) .EQ. 1) THEN
+          IF(ISAXIS(3) .EQ. -1) THEN
+            IZ=0
+          ELSE IF(ISAXIS(3) .EQ. 1) THEN
+            IZ=NSCELL(3)-1
+          ENDIF
+          IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+          DO IY=0,NSCELL(2)-1
+            IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+            DO IX=IY,NSCELL(1)-1
+              IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+              ILOCD=IOFYZ+IX+NFCELL(1)+1
+              IGEN=IUNFLD(1,ILOCD)
+              ITSYM(3,IGEN)=ISAXIS(3)
+            ENDDO
+          ENDDO
+        ENDIF
+      ELSE IF(IDIAG .EQ. 1) THEN
+*----
+*  Process X+ Y- diagonal symmetry
+*----
+        DO IZ=0,NSCELL(3)-1
+          IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+          DO IY=0,NSCELL(2)-1
+            IGENT=IGEN+IY+2
+            IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+            IX=IY
+            IGEN=IGEN+1
+            IF(IGEN .GT. NBOCEL) CALL XABORT(NAMSBR//
+     >      ': Cell number exceeds number of cells permitted')
+            IGENT=IGENT-1
+            ILOCD=IOFYZ+IX+NFCELL(1)+1
+            IUNFLD(1,ILOCD)=IGENT
+            IUNFLD(2,ILOCD)=1
+            ITSYM(4,IGENT)=IDIAG
+            DO IX=IY-1,0,-1
+              IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+              IOFYZR=(IX+NFCELL(2)+IOFZ)*NUCELL(1)
+              IGEN=IGEN+1
+              IF(IGEN .GT. NBOCEL) CALL XABORT(NAMSBR//
+     >        ': Cell number exceeds number of cells permitted')
+              IGENT=IGENT-1
+              ILOCD=IOFYZ+IX+NFCELL(1)+1
+              ILOCR=IOFYZR+IY+NFCELL(1)+1
+              IUNFLD(1,ILOCD)=IGENT
+              IUNFLD(2,ILOCD)=1
+              IUNFLD(1,ILOCR)=IGENT
+              IUNFLD(2,ILOCR)=NXTTRS(1,2)
+            ENDDO
+          ENDDO
+        ENDDO
+*----
+*  Identify cells to tests for X
+*  reflection symmetry
+*----
+        IF(ISAXIS(1) .EQ. -1) THEN
+          IX=0
+          DO IZ=0,NSCELL(3)-1
+            IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+            DO IY=0,NSCELL(2)-1
+              IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+              ILOCD=IOFYZ+IX+NFCELL(1)+1
+              IGEN=IUNFLD(1,ILOCD)
+              ITSYM(1,IGEN)=ISAXIS(1)
+            ENDDO
+          ENDDO
+        ENDIF
+*----
+*  Identify cells to tests for Y
+*  reflection symmetry
+*----
+        IF(ISAXIS(2) .EQ. 1) THEN
+          IY=NSCELL(2)-1
+          DO IZ=0,NSCELL(3)-1
+            IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+            IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+            DO IX=IY,0,-1
+              IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+              ILOCD=IOFYZ+IX+NFCELL(1)+1
+              IGEN=IUNFLD(1,ILOCD)
+              ITSYM(2,IGEN)=ISAXIS(2)
+            ENDDO
+          ENDDO
+        ENDIF
+*----
+*  Identify cells to tests for Z
+*  reflection symmetry
+*----
+        IF(ABS(ISAXIS(3)) .EQ. 1) THEN
+          IF(ISAXIS(3) .EQ. -1) THEN
+            IZ=0
+          ELSE IF(ISAXIS(3) .EQ. 1) THEN
+            IZ=NSCELL(3)-1
+          ENDIF
+          IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+          DO IY=0,NSCELL(2)-1
+            IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+            DO IX=IY,0,-1
+              IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+              ILOCD=IOFYZ+IX+NFCELL(1)+1
+              IGEN=IUNFLD(1,ILOCD)
+              ITSYM(3,IGEN)=ISAXIS(3)
+            ENDDO
+          ENDDO
+        ENDIF
+      ELSE
+        DO IZ=0,NSCELL(3)-1
+          IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+          DO IY=0,NSCELL(2)-1
+            IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+            DO IX=0,NSCELL(1)-1
+              IGEN=IGEN+1
+              IF(IGEN .GT. NBOCEL) CALL XABORT(NAMSBR//
+     >        ': Cell number exceeds number of cells permitted')
+              ILOCD=IOFYZ+IX+NFCELL(1)+1
+              IUNFLD(1,ILOCD)=IGEN
+              IUNFLD(2,ILOCD)=1
+            ENDDO
+          ENDDO
+        ENDDO
+*----
+*  Identify cells to tests for X
+*  reflection symmetry
+*----
+        IF(ABS(ISAXIS(1)) .EQ. 1) THEN
+          IF(ISAXIS(1) .EQ. -1) THEN
+            IX=0
+          ELSE IF(ISAXIS(1) .EQ. 1) THEN
+            IX=NSCELL(1)-1
+          ENDIF
+          DO IZ=0,NSCELL(3)-1
+            IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+            DO IY=0,NSCELL(2)-1
+              IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+              ILOCD=IOFYZ+IX+NFCELL(1)+1
+              IGEN=IUNFLD(1,ILOCD)
+              ITSYM(1,IGEN)=ISAXIS(1)
+            ENDDO
+          ENDDO
+        ENDIF
+*----
+*  Identify cells to tests for Y
+*  reflection symmetry
+*----
+        IF(ABS(ISAXIS(2)) .EQ. 1) THEN
+          IF(ISAXIS(2) .EQ. -1) THEN
+            IY=0
+          ELSE IF(ISAXIS(2) .EQ. 1) THEN
+            IY=NSCELL(2)-1
+          ENDIF
+          DO IZ=0,NSCELL(3)-1
+            IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+            IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+            DO IX=0,NSCELL(1)-1
+              ILOCD=IOFYZ+IX+NFCELL(1)+1
+              IGEN=IUNFLD(1,ILOCD)
+              ITSYM(2,IGEN)=ISAXIS(2)
+            ENDDO
+          ENDDO
+        ENDIF
+*----
+*  Identify cells to tests for Z
+*  reflection symmetry
+*----
+        IF(ABS(ISAXIS(3)) .EQ. 1) THEN
+          IF(ISAXIS(3) .EQ. -1) THEN
+            IZ=0
+          ELSE IF(ISAXIS(3) .EQ. 1) THEN
+            IZ=NSCELL(3)-1
+          ENDIF
+          IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+          DO IY=0,NSCELL(2)-1
+            IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+            DO IX=0,NSCELL(1)-1
+              ILOCD=IOFYZ+IX+NFCELL(1)+1
+              IGEN=IUNFLD(1,ILOCD)
+              ITSYM(3,IGEN)=ISAXIS(3)
+            ENDDO
+          ENDDO
+        ENDIF
+      ENDIF
+      DO ILOCD=1,NBOCEL
+        IF(ITSYM(4,ILOCD) .EQ. -1) THEN
+          IF(ITSYM(2,ILOCD) .EQ. -1) THEN
+            ITSYM(1,ILOCD)=1
+          ELSE IF(ITSYM(1,ILOCD) .EQ. 1) THEN
+            ITSYM(2,ILOCD)=-1
+          ENDIF
+        ELSE IF(ITSYM(4,ILOCD) .EQ. 1) THEN
+          IF(ITSYM(2,ILOCD) .EQ. 1) THEN
+            ITSYM(1,ILOCD)=-1
+          ELSE IF(ITSYM(1,ILOCD) .EQ. -1) THEN
+            ITSYM(2,ILOCD)=1
+          ENDIF
+        ENDIF
+      ENDDO
+      IF(ISAXIS(1) .NE. 0) THEN
+        IF(ISAXIS(1) .EQ. -2) THEN
+*----
+*  SSYM X-
+*  Fill position IXR=1,NSCELL(1) with cells at
+*  position IXD=NUCELL(1)-IXR+1
+*----
+          DO IZ=0,NSCELL(3)-1
+            IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+            DO IY=0,NSCELL(2)-1
+              IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+              DO IX=1,NSCELL(1)
+                ILOCD=IOFYZ+NUCELL(1)+1-IX
+                ILOCR=IOFYZ+IX
+                IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD)
+                IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),1)
+              ENDDO
+            ENDDO
+          ENDDO
+        ELSE IF(ISAXIS(1) .EQ. -1) THEN
+*----
+*  SYME X-
+*  Fill position IXR=1,NSCELL(1)-1 with cells at
+*  position IXD=NUCELL(1)-IXR+1
+*  set test flag for IX=NSCELL(1)
+*----
+          DO IZ=0,NSCELL(3)-1
+            IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+            DO IY=0,NSCELL(2)-1
+              IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+              DO IX=1,NSCELL(1)-1
+                ILOCD=IOFYZ+NUCELL(1)+1-IX
+                ILOCR=IOFYZ+IX
+                IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD)
+                IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),1)
+              ENDDO
+            ENDDO
+          ENDDO
+        ELSE IF(ISAXIS(1) .EQ. 1) THEN
+*----
+*  SYME X+
+*  Fill position IXR=NUCELL(1)-IXD+1 with cell
+*  at position IXD=1,NSCELL(1)-1
+*  set test flag for IX=NSCELL(1)
+*----
+          DO IZ=0,NSCELL(3)-1
+            IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+            DO IY=0,NSCELL(2)-1
+              IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+              DO IX=1,NSCELL(1)-1
+                ILOCD=IOFYZ+IX
+                ILOCR=IOFYZ+NUCELL(1)-IX+1
+                IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD)
+                IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),1)
+              ENDDO
+            ENDDO
+          ENDDO
+        ELSE IF(ISAXIS(1) .EQ. 2) THEN
+*----
+*  SSYM X+
+*  Fill position IXR=NUCELL(1)-IXD+1 with cell
+*  at position IXD=1,NSCELL(1)
+*----
+          DO IZ=0,NSCELL(3)-1
+            IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+            DO IY=0,NSCELL(2)-1
+              IOFYZ=(IY+NFCELL(2)+IOFZ)*NUCELL(1)
+              DO IX=1,NSCELL(1)
+                ILOCD=IOFYZ+IX
+                ILOCR=IOFYZ+NUCELL(1)-IX+1
+                IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD)
+                IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),1)
+              ENDDO
+            ENDDO
+          ENDDO
+        ENDIF
+        NSCELL(1)=MAX(1,NUCELL(1))
+      ENDIF
+      IF(ISAXIS(2) .NE. 0) THEN
+        IF(ISAXIS(2) .EQ. -2) THEN
+*----
+*  SSYM Y-
+*  Fill position IYR=1,NSCELL(2) with cells at
+*  position IYD=NUCELL(2)-IYR+1
+*----
+          DO IZ=0,NSCELL(3)-1
+            IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+            DO IY=1,NSCELL(2)
+              IOFYZ=(NUCELL(2)-IY+IOFZ)*NUCELL(1)
+              IOFYZR=(IY-1+IOFZ)*NUCELL(1)
+              DO IX=1,NSCELL(1)
+                ILOCD=IOFYZ+IX
+                ILOCR=IOFYZR+IX
+                IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD)
+                IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),3)
+              ENDDO
+            ENDDO
+          ENDDO
+        ELSE IF(ISAXIS(2) .EQ. -1) THEN
+*----
+*  SYME Y-
+*  Fill position IYR=1,NSCELL(2)-1 with cells at
+*  position IYD=NUCELL(2)-IYR+1
+*  set test flag for IY=NSCELL(2)
+*----
+          DO IZ=0,NSCELL(3)-1
+            IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+            DO IY=1,NSCELL(2)-1
+              IOFYZ=(NUCELL(2)-IY+IOFZ)*NUCELL(1)
+              IOFYZR=(IY-1+IOFZ)*NUCELL(1)
+              DO IX=1,NSCELL(1)
+                ILOCD=IOFYZ+IX
+                ILOCR=IOFYZR+IX
+                IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD)
+                IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),3)
+              ENDDO
+            ENDDO
+          ENDDO
+        ELSE IF(ISAXIS(2) .EQ. 1) THEN
+*----
+*  SYME Y+
+*  Fill position IYR=NUCELL(2)-IYD+1 with cell
+*  at position IYD=1,NSCELL(2)-1
+*  set test flag for IY=NSCELL(2)
+*----
+          DO IZ=0,NSCELL(3)-1
+            IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+            DO IY=1,NSCELL(2)-1
+              IOFYZR=(NUCELL(2)-IY+IOFZ)*NUCELL(1)
+              IOFYZ=(IY-1+IOFZ)*NUCELL(1)
+              DO IX=1,NSCELL(1)
+                ILOCD=IOFYZ+IX
+                ILOCR=IOFYZR+IX
+                IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD)
+                IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),3)
+              ENDDO
+            ENDDO
+          ENDDO
+        ELSE IF(ISAXIS(2) .EQ. 2) THEN
+*----
+*  SSYM Y+
+*  Fill position IYR=NUCELL(2)-IYD+1 with cell
+*  at position IYD=1,NSCELL(2)
+*----
+          DO IZ=0,NSCELL(3)-1
+            IOFZ=(IZ+NFCELL(3))*NUCELL(2)
+            DO IY=1,NSCELL(2)
+              IOFYZR=(NUCELL(2)-IY+IOFZ)*NUCELL(1)
+              IOFYZ=(IY-1+IOFZ)*NUCELL(1)
+              DO IX=1,NSCELL(1)
+                ILOCD=IOFYZ+IX
+                ILOCR=IOFYZR+IX
+                IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD)
+                IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),3)
+              ENDDO
+            ENDDO
+          ENDDO
+        ENDIF
+        NSCELL(2)=MAX(1,NUCELL(2))
+      ENDIF
+      IF(ISAXIS(3) .NE. 0) THEN
+        IF(ISAXIS(3) .EQ. -2) THEN
+*----
+*  SSYM Z-
+*  Fill position IZR=1,NSCELL(3) with cells at
+*  position IZD=NSUC(3)-IZR+1
+*----
+          DO IZ=1,NSCELL(3)
+            IOFZR=(IZ-1)*NUCELL(2)
+            IOFZ=(NSUC(3)-IZ)*NUCELL(2)
+            DO IY=1,NSCELL(2)
+              IOFYZ=(IY-1+IOFZ)*NUCELL(1)
+              IOFYZR=(IY-1+IOFZR)*NUCELL(1)
+              DO IX=1,NSCELL(1)
+                ILOCD=IOFYZ+IX
+                ILOCR=IOFYZR+IX
+                IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD)
+                IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),-1)
+              ENDDO
+            ENDDO
+          ENDDO
+        ELSE IF(ISAXIS(3) .EQ. -1) THEN
+*----
+*  SYME Z-
+*  Fill position IZR=1,NSCELL(3)-1 with cells at
+*  position IZD=NSUC(3)-IZR+1
+*  set test flag for IZ=NSCELL(3)
+*----
+          DO IZ=1,NSCELL(3)-1
+            IOFZR=(IZ-1)*NUCELL(2)
+            IOFZ=(NSUC(3)-IZ)*NUCELL(2)
+            DO IY=1,NSCELL(2)
+              IOFYZ=(IY-1+IOFZ)*NUCELL(1)
+              IOFYZR=(IY-1+IOFZR)*NUCELL(1)
+              DO IX=1,NSCELL(1)
+                ILOCD=IOFYZ+IX
+                ILOCR=IOFYZR+IX
+                IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD)
+                IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),-1)
+              ENDDO
+            ENDDO
+          ENDDO
+        ELSE IF(ISAXIS(3) .EQ. 1) THEN
+*----
+*  SYME Z+
+*  Fill position IZR=NSUC(3)-IZD+1 with cell
+*  at position IZD=1,NSCELL(3)-1
+*  set test flag for IZ=NSCELL(3)
+*----
+          DO IZ=1,NSCELL(3)-1
+            IOFZ=(IZ-1)*NUCELL(2)
+            IOFZR=(NSUC(3)-IZ)*NUCELL(2)
+            DO IY=1,NSCELL(2)
+              IOFYZ=(IY-1+IOFZ)*NUCELL(1)
+              IOFYZR=(IY-1+IOFZR)*NUCELL(1)
+              DO IX=1,NSCELL(1)
+                ILOCD=IOFYZ+IX
+                ILOCR=IOFYZR+IX
+                IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD)
+                IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),-1)
+              ENDDO
+            ENDDO
+          ENDDO
+        ELSE IF(ISAXIS(3) .EQ. 2) THEN
+*----
+*  SSYM Z+
+*  Fill position IZR=NSUC(3)-IZD+1 with cell
+*  at position IZD=1,NSCELL(3)
+*----
+          DO IZ=1,NSCELL(3)
+            IOFZ=(IZ-1)*NUCELL(2)
+            IOFZR=(NSUC(3)-IZ)*NUCELL(2)
+            DO IY=1,NSCELL(2)
+              IOFYZ=(IY-1+IOFZ)*NUCELL(1)
+              IOFYZR=(IY-1+IOFZR)*NUCELL(1)
+              DO IX=1,NSCELL(1)
+                ILOCD=IOFYZ+IX
+                ILOCR=IOFYZR+IX
+                IUNFLD(1,ILOCR)=IUNFLD(1,ILOCD)
+                IUNFLD(2,ILOCR)=NXTTRS(IUNFLD(2,ILOCD),-1)
+              ENDDO
+            ENDDO
+          ENDDO
+        ENDIF
+        NSCELL(3)=MAX(1,NSUC(3))
+      ENDIF
+*----
+*  Localize external faces
+*  1. X- (1) AND X+ (2)
+*----
+      DO IZ=1,NSUC(3)
+        DO IY=1,NUCELL(2)
+*          write(6,*) ' X faces =',IY,IZ
+          ILOCD=NUCELL(1)*(IY-1+NUCELL(2)*(IZ-1))+1
+          IF(IUNFLD(2,ILOCD) .EQ. 1) THEN
+            IGEN=IUNFLD(1,ILOCD)
+            IDFEX(1,IGEN)=1
+            IDFRT(1,IGEN)=IGEN
+          ENDIF
+*          write(6,*) ' X - =',ILOCD,IUNFLD(2,ILOCD),IDFEX(1,IGEN)
+          ILOCD=NUCELL(1)*(IY-1+NUCELL(2)*(IZ-1))+NUCELL(1)
+          IF(IUNFLD(2,ILOCD) .EQ. 1) THEN
+            IGEN=IUNFLD(1,ILOCD)
+            IDFEX(2,IGEN)=1
+            IDFRT(2,IGEN)=IGEN
+          ENDIF
+*          write(6,*) ' X + =',ILOCD,IUNFLD(2,ILOCD),IDFEX(2,IGEN)
+        ENDDO
+      ENDDO
+*----
+*  2. Y- (3) Y+ (4)
+*----
+      DO IZ=1,NSUC(3)
+        DO IX=1,NUCELL(1)
+*          write(6,*) ' Y faces =',IX,IZ
+          ILOCD=NUCELL(1)*NUCELL(2)*(IZ-1)+IX
+          IF(IUNFLD(2,ILOCD) .EQ. 1) THEN
+            IGEN=IUNFLD(1,ILOCD)
+            IDFEX(3,IGEN)=1
+            IDFRT(3,IGEN)=IGEN
+          ENDIF
+*          write(6,*) ' Y - =',ILOCD,IUNFLD(2,ILOCD),IDFEX(3,IGEN)
+          ILOCD=NUCELL(1)*(NUCELL(2)-1+NUCELL(2)*(IZ-1))+IX
+          IF(IUNFLD(2,ILOCD) .EQ. 1) THEN
+            IGEN=IUNFLD(1,ILOCD)
+            IDFEX(4,IGEN)=1
+            IDFRT(4,IGEN)=IGEN
+          ENDIF
+*          write(6,*) ' Y + =',ILOCD,IUNFLD(2,ILOCD),IDFEX(4,IGEN)
+        ENDDO
+      ENDDO
+*----
+*  3. Z- (5) Z+ (6)
+*----
+      DO IY=1,NUCELL(2)
+        DO IX=1,NUCELL(1)
+*          write(6,*) ' Z faces =',IX,IY
+          ILOCD=NUCELL(1)*(IY-1)+IX
+          IF(IUNFLD(2,ILOCD) .EQ. 1) THEN
+            IGEN=IUNFLD(1,ILOCD)
+            IDFEX(5,IGEN)=1
+            IDFRT(5,IGEN)=IGEN
+          ENDIF
+*          write(6,*) ' Z - =',ILOCD,IUNFLD(2,ILOCD),IDFEX(5,IGEN)
+          ILOCD=NUCELL(1)*(IY-1+NUCELL(2)*(NSUC(3)-1))+IX
+          IF(IUNFLD(2,ILOCD) .EQ. 1) THEN
+            IGEN=IUNFLD(1,ILOCD)
+            IDFEX(6,IGEN)=1
+            IDFRT(6,IGEN)=IGEN
+          ENDIF
+*          write(6,*) ' Z + =',ILOCD,IUNFLD(2,ILOCD),IDFEX(6,IGEN)
+        ENDDO
+      ENDDO
+*----
+*  For translation BC, find translated cell
+*  1. X translation
+*----
+      IF(ISAXIS(1) .EQ. 3) THEN
+        DO IGEN=1,NBOCEL
+          IF(IDFEX(1,IGEN) .EQ. 1) THEN
+            DO IZ=1,NSUC(3)
+              DO IY=1,NUCELL(2)
+                ILOCD=NUCELL(1)*(IY-1+NUCELL(2)*(IZ-1))+1
+                IF(IUNFLD(2,ILOCD) .EQ. 1) THEN
+                  IF(IUNFLD(1,ILOCD) .EQ. IGEN) THEN
+                    ILOCD=NUCELL(1)*(IY-1+NUCELL(2)*(IZ-1))+NUCELL(1)
+                    IGENT=IUNFLD(1,ILOCD)
+                    IDFRT(1,IGEN)=IGENT
+                    IDFRT(2,IGENT)=IGEN
+                  ENDIF
+                ENDIF
+              ENDDO
+            ENDDO
+          ENDIF
+        ENDDO
+      ENDIF
+*----
+*  2. Y translation
+*----
+      IF(ISAXIS(2) .EQ. 3) THEN
+        DO IGEN=1,NBOCEL
+          IF(IDFEX(3,IGEN) .EQ. 1) THEN
+            DO IZ=1,NSUC(3)
+              DO IX=1,NUCELL(1)
+                ILOCD=NUCELL(1)*NUCELL(2)*(IZ-1)+IX
+                IF(IUNFLD(2,ILOCD) .EQ. 1) THEN
+                  IF(IUNFLD(1,ILOCD) .EQ. IGEN) THEN
+                    ILOCD=NUCELL(1)*(NUCELL(2)-1+NUCELL(2)*(IZ-1))+IX
+                    IGENT=IUNFLD(1,ILOCD)
+                    IDFRT(3,IGEN)=IGENT
+                    IDFRT(4,IGENT)=IGEN
+                  ENDIF
+                ENDIF
+              ENDDO
+            ENDDO
+          ENDIF
+        ENDDO
+      ENDIF
+*----
+*  3. Z translation
+*----
+      IF(ISAXIS(3) .EQ. 3) THEN
+        DO IGEN=1,NBOCEL
+          IF(IDFEX(5,IGEN) .EQ. 1) THEN
+            DO IY=1,NUCELL(2)
+              DO IX=1,NUCELL(1)
+                ILOCD=NUCELL(1)*(IY-1)+IX
+                IF(IUNFLD(2,ILOCD) .EQ. 1) THEN
+                  IF(IUNFLD(1,ILOCD) .EQ. IGEN) THEN
+                    ILOCD=NUCELL(1)*(IY-1+NUCELL(2)*(NSUC(3)-1))+IX
+                    IGENT=IUNFLD(1,ILOCD)
+                    IDFRT(5,IGEN)=IGENT
+                    IDFRT(6,IGENT)=IGEN
+                  ENDIF
+                ENDIF
+              ENDDO
+            ENDDO
+          ENDIF
+        ENDDO
+      ENDIF
+*----
+*  Analyze translation boundary
+*----
+*----
+*  Compute the number of times each cell appears
+*  after unfolding
+*----
+      DO IGEN=1,NBOCEL
+        DO ILOCD=1,NBUCEL
+          IF(ABS(IUNFLD(1,ILOCD)) .EQ. IGEN) THEN
+            IDFEX(0,IGEN)=IDFEX(0,IGEN)+1
+          ENDIF
+        ENDDO
+      ENDDO
+*----
+*  For 2-D cases reset components 5, 6 of IDFEX to 0
+*----
+      IF(NDIM .EQ. 2) THEN
+        DO IGEN=1,NBOCEL
+          IDFEX(5,IGEN)=0
+          IDFEX(6,IGEN)=0
+        ENDDO
+      ENDIF
+*----
+*  Processing finished:
+*  print routine output and closing header if required
+*  and return
+*----
+      IF(IPRINT .GE. 10) THEN
+        WRITE(IOUT,6002)
+        DO IZ=1,NSUC(3)
+          IF(NDIM .EQ. 3) THEN
+            WRITE(IOUT,6003) IZ
+          ENDIF
+          WRITE(IOUT,6004) (IX,IX=1,NUCELL(1))
+          WRITE(IOUT,6012)
+          DO IY=NUCELL(2),1,-1
+            ILOCD=((IZ-1)*NUCELL(2)+(IY-1))*NUCELL(1)
+            WRITE(IOUT,6005) IY,
+     >        (IUNFLD(1,IX),IX=ILOCD+1,ILOCD+NUCELL(1))
+          ENDDO
+        ENDDO
+        WRITE(IOUT,6008)
+        DO IZ=1,NSUC(3)
+          IF(NDIM .EQ. 3) THEN
+            WRITE(IOUT,6003) IZ
+          ENDIF
+          WRITE(IOUT,6004) (IX,IX=1,NUCELL(1))
+          WRITE(IOUT,6012)
+          DO IY=NUCELL(2),1,-1
+            ILOCD=((IZ-1)*NUCELL(2)+(IY-1))*NUCELL(1)
+            WRITE(IOUT,6013) IY,
+     >        (CTRN(IUNFLD(2,IX)),IX=ILOCD+1,ILOCD+NUCELL(1))
+          ENDDO
+        ENDDO
+        WRITE(IOUT,6006)
+        DO ILOCD=1,NBOCEL
+          WRITE(IOUT,6007)
+     >    ILOCD,(ITSYM(IX,ILOCD),IX=1,4)
+        ENDDO
+        WRITE(IOUT,6009)
+        DO ILOCD=1,NBOCEL
+          IF(NDIM .EQ. 3) THEN
+            WRITE(IOUT,6007)
+     >      ILOCD,(IDFEX(IX,ILOCD),IX=1,6),IDFEX(0,ILOCD)
+          ELSE
+            WRITE(IOUT,6011)
+     >      ILOCD,(IDFEX(IX,ILOCD),IX=1,4),IDFEX(0,ILOCD)
+          ENDIF
+        ENDDO
+        WRITE(IOUT,6010)
+        DO ILOCD=1,NBOCEL
+          WRITE(IOUT,6007)
+     >    ILOCD,(IDFRT(IX,ILOCD),IX=1,2*NDIM)
+        ENDDO
+        WRITE(IOUT,6001) NAMSBR
+      ENDIF
+      RETURN
+*----
+*  Output formats
+*----
+ 6000 FORMAT('(* Output from --',A6,'-- follows ')
+ 6001 FORMAT('   Output from --',A6,'-- completed *)')
+ 6002 FORMAT(' Cells in assembly')
+ 6003 FORMAT(' Plane IZ =',I6)
+ 6004 FORMAT(' IX=',8X,24(I7,1X))
+ 6005 FORMAT(' IY=',I7,1X,24(I7.7,1X))
+ 6006 FORMAT(/' Symmetrized cell     X    Y    Z    D')
+ 6007 FORMAT(' Cell ',I7.7,5X,20I5)
+ 6008 FORMAT(/' Cell rotations in assembly')
+ 6009 FORMAT(/' External faces      -X   +X   -Y   +Y   -Z   +Z   ND')
+ 6010 FORMAT(/' Coupled  faces      -X   +X   -Y   +Y   -Z   +Z  ')
+ 6011 FORMAT(' Cell ',I7.7,5X,4I5,10X,14I5)
+ 6012 FORMAT('X/Y')
+ 6013 FORMAT(' IY=',I7,1X,24(5X,A2,1X))
+      END