*=== lattic ===========================================================*
*
      SUBROUTINE LATTIC ( XB, WB, DIST, SB, UB, IR, IRLTGG, IRLT, IFLAG)

* === For FLUKA === *
      INCLUDE '(DBLPRC)'
      INCLUDE '(DIMPAR)'
      INCLUDE '(IOUNIT)'
* === For Plotgeom === *
*     IMPLICIT DOUBLE PRECISION (A-H,O-Z)
*     PARAMETER ( LUNOUT = 11 )
*
*----------------------------------------------------------------------*
*                                                                      *
*     Copyright (C) 1993-2017      by    Alfredo Ferrari & Paola Sala  *
*     All Rights Reserved.                                             *
*                                                                      *
*                                                                      *
*     LATTIC: user written routine which must return the tracking point*
*     and direction ( SB, UB ) corresponding to region number IR, cell *
*     number IRLTGG and real position/direction XB, WB                 *
*                                                                      *
*     Created on 16 December 1993  by    Alfredo Ferrari & Paola Sala  *
*                                                   Infn - Milan       *
*                                                                      *
*     Last change on  28-Feb-17    by    Alfredo Ferrari               *
*                                                                      *
*----------------------------------------------------------------------*
*
* === For FLUKA === *
      INCLUDE '(COMEPS)'
      INCLUDE '(GLTLOC)'
      INCLUDE '(RTGMMV)'
* === For Plotgeom === *
*     PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
* === End Plotgeom === *
      LOGICAL LFIRST
* Start_GFort_seq
      INTEGER*8 IRLTPT
* End_GFort_seq
* Start_G95_seq
*     INTEGER*8 IRLTPT
* End_G95_seq
      DIMENSION IRLT (*)
      DIMENSION XB   (3), WB (3), SB (3), UB (3), UN (3)
      SAVE IRLSAV, LFIRST
*
      DATA LFIRST /.TRUE./
      DATA IRLSAV / -1 /
*
      INTEGER IND(15000)
      DOUBLE PRECISION DELX(15000)
      DOUBLE PRECISION DELY(15000)
      INTEGER I
      DOUBLE PRECISION BUFDELX
      DOUBLE PRECISION BUFDELY
      INTEGER BUFI
*
      SAVE IND, DELX, DELY
*  +-------------------------------------------------------------------*
*  |  First time initialization:
      IF ( LFIRST ) THEN
         LFIRST = .FALSE.
         WRITE(*,*) 'LATTIC FIRST CALL'
         DO I = 1, 15000
            IND(I) = I
            DELX(I) = 0.
            DELY(I) = 0.
         END DO
         WRITE(*,*) 'INITIALIZATION OF DELTA X,Y ARRAYS DONE'
*
         OPEN(2, ACTION = 'READ', FILE = '../Cells.dat')
         DO 
            READ(2, FMT = *) BUFI, BUFDELX, BUFDELY
            IF (BUFI .EQ. -1) THEN
               EXIT
            ENDIF
            DELX(BUFI) = BUFDELX
            DELY(BUFI) = BUFDELY
*            WRITE(*,*) BUFI, BUFDELX, BUFDELY
         END DO
         CLOSE(2)
      END IF
*  |
*  +-------------------------------------------------------------------*
*  +-------------------------------------------------------------------*
*  |
      IF ( IRLTGG .NE. IRLSAV ) THEN
         IRLTPT = IRLTGG - KLTCL0 + 1
*  |  How to get the lattice name out of the lattice number:
*  |  Get the region index corresponding to Irltgg
*        IRCELL = IRLT   ( IRLTPT )
*  |  Get the lattice name:
*        LTTNAM = LTTCNM ( IRCELL )
*  |  Get the region index corresponding to Irltgg
         IRCELL = IRLT   ( IRLTPT )
*  |  Get a possible rotation index for this region/lattice:
         KROT12 = ILTRTN ( IRCELL )
*  |  +----------------------------------------------------------------*
         SB (1) = XB (1) + DELX(IRCELL)
         SB (2) = XB (2) + DELY(IRCELL)
         SB (3) = XB (3)
         UB (1) = WB (1)
         UB (2) = WB (2)
         UB (3) = WB (3)
      ELSE IF ( IFLAG .LT. 0 )  THEN
         WRITE (LUNOUT,*)
     &   ' *** Lattic called with both Irltgg=Irlsav and Iflag < 0 ***'
         CALL FLABRT ('LATTIC', 'LATTIC_2')
      END IF
*  |
*  +-------------------------------------------------------------------*
      RETURN
*
*======================================================================*
*                                                                      *
*     Entry LATNOR:                                                    *
*                                                                      *
*======================================================================*
*
      ENTRY LATNOR ( UN, IRLTNO, IRLT )
*
*----------------------------------------------------------------------*
*                                                                      *
*     LATtice cell NORmal transformation:                              *
*                                                                      *
*     Input variables:                                                 *
*                      un(i) = normal components in the tracking re-   *
*                              ference system                          *
*                     irltno = present lattice cell #                  *
*     Output variables:                                                *
*                      un(i) = normal components in the problem re-    *
*                              ference system                          *
*                                                                      *
*----------------------------------------------------------------------*
*
      IRLTPT = IRLTNO - KLTCL0 + 1
*  Get the region index corresponding to Irltno
      IRCELL = IRLT   ( IRLTPT )
*  Get a possible rotation index for this region/lattice:
      KROT12 = ILTRTN ( IRCELL )
*  +-------------------------------------------------------------------*
*  |  One or two rotations are defined for this lattice:
      IF ( KROT12 .NE. 0 ) THEN
*  |  +----------------------------------------------------------------*
*  |  |  Two transformations:
         IF ( ABS ( KROT12 ) .GT. MODRTN ) THEN
            CALL DCDRTN ( .TRUE., KROTAT, KROTA2, KROT12, MODRTN )
*  |  |
*  |  +----------------------------------------------------------------*
*  |  |  One transformation:
         ELSE
            KROTAT = KROT12
            KROTA2 = 0
         END IF
*  |  |
*  |  +----------------------------------------------------------------*
*  |  +----------------------------------------------------------------*
*  |  |  A 2nd (positive) rotation is defined for this lattice:
         IF ( KROTA2 .GT. 0 ) THEN
            CALL UNDRTO ( 1, UN (1), UN (2), UN (3), KROTA2 )
*  |  |
*  |  +----------------------------------------------------------------*
*  |  |  A 2nd (negative) rotation is defined for this lattice:
         ELSE IF ( KROTA2 .LT. 0 ) THEN
            CALL DORTNO ( 1, UN (1), UN (2), UN (3), -KROTA2 )
         END IF
*  |  |
*  |  +----------------------------------------------------------------*
*  |  +----------------------------------------------------------------*
*  |  |  A (positive) rotation is defined for this lattice:
         IF ( KROTAT .GT. 0 ) THEN
            CALL UNDRTO ( 1, UN (1), UN (2), UN (3), KROTAT )
*  |  |
*  |  +----------------------------------------------------------------*
*  |  |  A (negative) rotation is defined for this lattice:
         ELSE IF ( KROTAT .LT. 0 ) THEN
            CALL DORTNO ( 1, UN (1), UN (2), UN (3), -KROTAT )
         END IF
*  |  |
*  |  +----------------------------------------------------------------*
         RETURN
      END IF
*  |
*  +-------------------------------------------------------------------*
*      WRITE (*,*) 'LATTIC IRLT ',IRLTNO, KROTAT, KROTA2, KROT12
*      CALL FFLUSH
      UN (1) = UN (1)
      UN (2) = UN (2)
      UN (3) = UN (3)
      RETURN
*=== End of subroutine lattic =========================================*
      END

