*$ CREATE LATTIC.FOR
*COPY LATTIC
*
*=== lattic ===========================================================*
*
      SUBROUTINE LATTIC ( XB, WB, DIST, SB, UB, IR, IRLTGG, IRLT, IFLAG)
* === For FLUKA === *
      INCLUDE '(DBLPRC)'
      INCLUDE '(DIMPAR)'
      INCLUDE '(IOUNIT)'
      INCLUDE '(GLTLOC)'
      INCLUDE '(RTGMMV)'
*      
      LOGICAL LFIRST
      DIMENSION IRLT (*)
      DIMENSION XB (3), WB (3), SB (3), UB (3), UN (3)
      SAVE IRLSAV, LFIRST
*
      DATA LFIRST /.TRUE./
      DATA IRLSAV / -1 /
*
*  +-------------------------------------------------------------------*
*  |  First time initialization:
      IF ( LFIRST ) THEN
         LFIRST = .FALSE.
      END IF
*  |
*  +-------------------------------------------------------------------*
*  +-------------------------------------------------------------------*
*  |
      IF ( IRLTGG .NE. IRLSAV ) THEN
*  |  How to get the lattice name out of the lattice number:
*  |  Get the region index corresponding to Irltgg
*        IRCELL = IRLT ( IRLTGG - KLTCL0 + 1 )
*  |  Get the lattice name:
*        LTTNAM = LTTCNM (IRCELL)
*  |  Get the region index corresponding to Irltgg
        IRCELL = IRLT ( IRLTGG - KLTCL0 + 1 )
*  |  Get a possible rotation index for this region/lattice:
        KROTAT = ILTRTN ( IRCELL )

        HSHIFT = 0.2
        
        IF(IRLTGG.LE.50)THEN
           SB (1) = XB (1)
           SB (2) = XB (2)
           SB (3) = XB (3)
        ELSE IF(IRLTGG.LE.100)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-50)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 1
        ELSE IF(IRLTGG.LE.150)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-100)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 2
        ELSE IF(IRLTGG.LE.200)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-150)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 3
        ELSE IF(IRLTGG.LE.250)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-200)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 4
        ELSE IF(IRLTGG.LE.300)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-250)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 5
        ELSE IF(IRLTGG.LE.350)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-300)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 6
        ELSE IF(IRLTGG.LE.400)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-350)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 7
        ELSE IF(IRLTGG.LE.450)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-400)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 8
        ELSE IF(IRLTGG.LE.500)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-450)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 9
        ELSE IF(IRLTGG.LE.550)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-500)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 10
        ELSE IF(IRLTGG.LE.600)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-550)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 11
        ELSE IF(IRLTGG.LE.650)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-600)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 12
        ELSE IF(IRLTGG.LE.700)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-650)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 13
        ELSE IF(IRLTGG.LE.750)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-700)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 14
        ELSE IF(IRLTGG.LE.800)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-750)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 15
        ELSE IF(IRLTGG.LE.850)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-800)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 16
        ELSE IF(IRLTGG.LE.900)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-850)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 17
        ELSE IF(IRLTGG.LE.950)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-900)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 18
        ELSE IF(IRLTGG.LE.1000)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-950)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 19
        ELSE IF(IRLTGG.LE.1050)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1000)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 20
        ELSE IF(IRLTGG.LE.1100)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1050)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 21
        ELSE IF(IRLTGG.LE.1150)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1100)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 22
        ELSE IF(IRLTGG.LE.1200)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1150)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 23
        ELSE IF(IRLTGG.LE.1250)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1200)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 24
        ELSE IF(IRLTGG.LE.1300)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1250)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 25
        ELSE IF(IRLTGG.LE.1350)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1300)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 26
        ELSE IF(IRLTGG.LE.1400)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1350)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 27
        ELSE IF(IRLTGG.LE.1450)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1400)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 28
        ELSE IF(IRLTGG.LE.1500)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1450)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 29
        ELSE IF(IRLTGG.LE.1550)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1500)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 30
        ELSE IF(IRLTGG.LE.1600)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1550)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 31
        ELSE IF(IRLTGG.LE.1650)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1600)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 32
        ELSE IF(IRLTGG.LE.1700)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1650)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 33
        ELSE IF(IRLTGG.LE.1750)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1700)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 34
        ELSE IF(IRLTGG.LE.1800)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1750)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 35
        ELSE IF(IRLTGG.LE.1850)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1800)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 36
        ELSE IF(IRLTGG.LE.1900)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1850)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 37
        ELSE IF(IRLTGG.LE.1950)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1900)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 38
        ELSE IF(IRLTGG.LE.2000)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-1950)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 39
        ELSE IF(IRLTGG.LE.2050)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-2000)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 40
        ELSE IF(IRLTGG.LE.2100)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-2050)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 41
        ELSE IF(IRLTGG.LE.2150)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-2100)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 42
        ELSE IF(IRLTGG.LE.2200)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-2150)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 43
        ELSE IF(IRLTGG.LE.2250)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-2200)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 44
        ELSE IF(IRLTGG.LE.2300)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-2250)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 45
        ELSE IF(IRLTGG.LE.2350)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-2300)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 46
        ELSE IF(IRLTGG.LE.2400)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-2350)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 47
        ELSE IF(IRLTGG.LE.2450)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-2400)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 48
        ELSE IF(IRLTGG.LE.2500)THEN
           SB (1) = XB (1) - HSHIFT * (IRLTGG-2450)
           SB (2) = XB (2)
           SB (3) = XB (3) - HSHIFT * 49
        ELSE
           SB (1) = XB (1) 
           SB (2) = XB (2)
           SB (3) = XB (3) 
        END IF

        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 ( 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                          *
*                                                                      *
*----------------------------------------------------------------------*
*
*  Get the region index corresponding to Irltno
      IRCELL = IRLT ( IRLTNO - KLTCL0 + 1 )
*  Get a possible rotation index for this region/lattice:
      KROTAT = ILTRTN ( IRCELL )
         UN (1) = UN (1)
         UN (2) = UN (2)
         UN (3) = UN (3)
      RETURN
*=== End of subroutine lattic =========================================*
      END











