*DECK NXTETH
      SUBROUTINE NXTETH(IPRINT,IDT   ,ILEV  ,NFSUR ,MAXMSP,
     >                  NS1   ,NR1   ,NS2   ,NR2   ,IEDIMG,DAMESH,
     >                  IX1   ,ID1   ,SV1   ,IX2   ,ID2   ,SV2   ,
     >                  MATRT ,NBSD  ,NBST  )
*
*----------
*
*Purpose:
* To built equivalent surface array for translational symmetry.
*
*Copyright:
* Copyright (C) 2005 Ecole Polytechnique de Montreal.
*
*Author(s):
* G. Marleau.
*
*Update(s):
* 2005/09/29: Validated with DRAGON and documented in
*             Report IGE-260.
*
*Reference:
*  G. Marleau,
*  \textsl{New Geometries Processing in DRAGON: The NXT: Module},
*  Report IGE-260, \'{E}cole Polytechnique de Montr\'{e}al,
*  Montr\'{e}al, 2005.
*
*Parameters: input
* IPRINT  print level.
* IDT     translation direction.
* ILEV    geometry level.
* NFSUR   final number of surfaces.
* MAXMSP  maximum number of elements in MESH array.
* NS1     maximum number of surfaces in splitted geometry 1.
* NR1     maximum number of regions in splitted geometry 1.
* NS2     maximum number of surfaces in splitted geometry 2.
* NR2     maximum number of regions in splitted geometry 2.
* IEDIMG  geometries state vector.
* DAMESH  final mesh description for geometry.
* IX1     local indexing of surfaces/regions for geometry 1.
* ID1     surface identifier after symmetry for geometry 1.
* SV1     area/volume of regions for geometry 1.
* IX2     local indexing of surfaces/regions for geometry 2.
* ID2     surface identifier after symmetry for geometry 2.
* SV2     area/volume of regions for geometry 2.
*
*Parameters: output
* MATRT   reflection/transmission surface coupling array.
* NBSD    number of direct surfaces considered.
* NBST    number of translated surfaces found.
*
*----------
*
      IMPLICIT         NONE
      INTEGER          NSTATE
      PARAMETER       (NSTATE=40)
*----
*  Subroutine arguments
*----
      INTEGER          IPRINT,IDT,ILEV,NFSUR,MAXMSP,NS1,NR1,NS2,NR2,
     >                 IEDIMG(NSTATE,2)
      DOUBLE PRECISION DAMESH(-1:MAXMSP,4,2)
      INTEGER          IX1(4,-NS1:NR1),ID1(NS1)
      DOUBLE PRECISION SV1(-NS1:NR1)
      INTEGER          IX2(4,-NS2:NR2),ID2(NS2)
      DOUBLE PRECISION SV2(-NS2:NR2)
      INTEGER          MATRT(NFSUR),NBSD,NBST
*----
*  Local parameters
*----
      INTEGER          IOUT
      CHARACTER        NAMSBR*6
      PARAMETER       (IOUT=6,NAMSBR='NXTETH')
*----
*  Local variables
*----
      INTEGER          ISVD,ISVT,
     >                 ISD,IST,IPU,IPV,IPW,IDIR
      DOUBLE PRECISION D1B,D1T,D2B,D2T
*----
*  Processing starts:
*  print routine openning output header if required
*  and initialize various parameters.
*----
      IF(IPRINT .GE. 100) THEN
        WRITE(IOUT,6000) NAMSBR
        WRITE(IOUT,6010) ILEV
      ENDIF
*----
*  Assume mesh in U, V and W identical and stored in element 1
*  of DAMESH
*----
      IDIR=1
      IF(IDT .EQ. 3) THEN
*----
*  Scan for bottom surfaces
*----
        DO ISVD=1,IEDIMG(9,1)
          IF(IX1(IDT,-ISVD) .EQ. -1) THEN
            NBSD=NBSD+1
*----
*  This surface in the good direction
*----
            ISD=ID1(ISVD)
            IF(ISD .GT. 0) THEN
*----
*  This is an external surface/locate mesh position
*----
              IPU=IX1(1,-ISVD)
              IPV=IX1(2,-ISVD)
              IPW=IX1(4,-ISVD)
*----
*  Scan IX2 for top surfaces
*----
              DO ISVT=1,IEDIMG(9,2)
                IF(IX2(IDT,-ISVT) .EQ. -2) THEN
                  IST=ID2(ISVT)
                  IF(IST .GT. 0) THEN
*----
*  This is an external surface
*  test if mesh position is compatible with
*  direct geometry
*----
                    IF(IPU .EQ. IX2(1,-ISVT) .AND.
     >                 IPV .EQ. IX2(2,-ISVT) .AND.
     >                 IPW .EQ. IX2(4,-ISVT) ) THEN
*----
*  This should be the translated surface we are seeking
*  Test if area and dimensions are compatible
*----
                      IF(SV1(-ISVD) .NE. SV2(-ISVT))
     >CALL XABORT(NAMSBR//': Translated surfaces are invalid')
                      IF(IPU .GT. 0) THEN
                        D1B=DAMESH(IPU-1,IDIR,1)-DAMESH(0,IDIR,1)
                        D1T=DAMESH(IPU,IDIR,1)-DAMESH(0,IDIR,1)
                        D2B=DAMESH(IPU-1,IDIR,2)-DAMESH(0,IDIR,2)
                        D2T=DAMESH(IPU,IDIR,2)-DAMESH(0,IDIR,2)
                        IF(D1B .NE. D2B .AND. D1T .NE. D2T)
     >CALL XABORT(NAMSBR//': U mesh for translation is invalid')
                      ENDIF
                      IF(IPV .GT. 0) THEN
                        D1B=DAMESH(IPV-1,IDIR,1)-DAMESH(0,IDIR,1)
                        D1T=DAMESH(IPV,IDIR,1)-DAMESH(0,IDIR,1)
                        D2B=DAMESH(IPV-1,IDIR,2)-DAMESH(0,IDIR,2)
                        D2T=DAMESH(IPV,IDIR,2)-DAMESH(0,IDIR,2)
                        IF(D1B .NE. D2B .AND. D1T .NE. D2T)
     >CALL XABORT(NAMSBR//': V mesh for translation is invalid')
                      ENDIF
                      IF(IPW .GT. 0) THEN
                        D1B=DAMESH(IPW-1,IDIR,1)-DAMESH(0,IDIR,1)
                        D1T=DAMESH(IPW,IDIR,1)-DAMESH(0,IDIR,1)
                        D2B=DAMESH(IPW-1,IDIR,2)-DAMESH(0,IDIR,2)
                        D2T=DAMESH(IPW,IDIR,2)-DAMESH(0,IDIR,2)
                        IF(D1B .NE. D2B .AND. D1T .NE. D2T)
     >CALL XABORT(NAMSBR//': W mesh for translation is invalid')
                      ENDIF
*----
*  Everything seems all right
*  couple surfaces
*----
                      NBST=NBST+1
                      MATRT(ISD)=IST
                      MATRT(IST)=ISD
                      GO TO 105
                    ENDIF
                  ENDIF
                ENDIF
              ENDDO
*----
*  Could not find translated surface
*----
              WRITE(IOUT,9000) ISD
 105          CONTINUE
            ENDIF
          ENDIF
        ENDDO
      ELSE
        CALL XABORT(NAMSBR//': Translation BC for hexagonal faces '//
     >'not programmed yet ')
      ENDIF
*----
*  Processing finished:
*  print routine closing output header if required
*  and return
*----
      IF(IPRINT .GE. 100) THEN
        WRITE(IOUT,6001) NAMSBR
      ENDIF
      RETURN
*----
*  Output formats
*----
 6000 FORMAT('(* Output from --',A6,'-- follows ')
 6001 FORMAT('   Output from --',A6,'-- completed *)')
 6010 FORMAT('Geometry level = ',I5)
 9000 FORMAT(' ***** Warning ***** '/
     >       '       Translated surface for ',I5,1X,'is absent')
      END
