*$ 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)'
* === For Morse & Plotgeom === *
*     IMPLICIT DOUBLE PRECISION (A-H,O-Z)
*
*----------------------------------------------------------------------*
*                                                                      *
*     Copyright (C) 1993-2006      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 03-mar-06     by    Alfredo Ferrari               *
*                                                                      *
*----------------------------------------------------------------------*
*
* === For FLUKA === *
      INCLUDE '(GLTLOC)'
      INCLUDE '(RTGMMV)'
* === For Morse & Plotgeom === *
*     PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
*     COMMON /TAPE/ INT, LUNOUT, IDUMMY(6)
* === End Morse & Plotgeom === *
      LOGICAL LFIRST
      DIMENSION IRLT (*)
      DIMENSION XB   (3), WB (3), SB (3), UB (3), UN (3)
      SAVE IRLSAV, LFIRST 
      DIMENSION XSTRXX(124),YSTRYY(124),ZSTRZZ(124)
*
      DATA LFIRST /.TRUE./
      DATA IRLSAV / -1 /
*
*  +-------------------------------------------------------------------*
*  |  First time initialization:
      IF ( LFIRST ) THEN
         LFIRST = .FALSE.
         icntxx=0
         do kkk=1,5 
          do jjj=1,5 
           do iii=1,5 
           if(iii.ne.3.or.jjj.ne.3.or.kkk.ne.3) then
            icntxx=icntxx+1
c            ZSTRZZ(icntxx) = (iii-3) * 112.500 * 2.0  
            ZSTRZZ(icntxx) = (iii-3) * 225.0
c            YSTRYY(icntxx) = (jjj-3) * 286.79 * 2.0 
            YSTRYY(icntxx) = (jjj-3) * 573.58
c            XSTRXX(icntxx) = (kkk-3) * 117.28 * 2.0 
            XSTRXX(icntxx) = (kkk-3) * 234.56 
           endif
           enddo
          enddo
         enddo
      END IF
*  |
c         WRITE (LUNOUT,*)  IRLTGG      
      IRCELL = IRLT ( IRLTGG - KLTCL0 + 1 )
      KROTAT = ILTRTN ( IRCELL )
      IF (IRLTGG.GE.211.AND.IRLTGG.LE.334 ) THEN
         WRITE(99,*) ' '
         WRITE(99,*) xb 
         WRITE(99,*) irltgg
         WRITE(99,*)  XSTRXX(IRLTGG-210),
     & YSTRYY(IRLTGG-210),ZSTRZZ(IRLTGG-210)
         SB (1) = XB (1) - XSTRXX(IRLTGG-210)
         SB (2) = XB (2) - YSTRYY(IRLTGG-210)
         SB (3) = XB (3) - ZSTRZZ(IRLTGG-210)
         UB (1) = WB (1)
         UB (2) = WB (2)
         UB (3) = WB (3)
      ELSE
          WRITE (LUNOUT,*)' NON-EXISTENT LATTICE: ',IRLTGG
*          CALL FLABRT( 'LATTIC','LATTIC')
      ENDIF  


      RETURN

*
*======================================================================*
*                                                                      *
*     Entry LATNOR:                                                    *
*                                                                      *
*======================================================================*
*
      ENTRY LATNOR ( UN, IRLTNO, IRLT )
c**  xxxx Short Circuited xxxx
*
*----------------------------------------------------------------------*
*                                                                      *
*     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
d      IRCELL = IRLT ( IRLTNO - KLTCL0 + 1 )
*  Get a possible rotation index for this region/lattice:
d      KROTAT = ILTRTN ( IRCELL )
*  +-------------------------------------------------------------------*
*  |  !! This part is not yet tested!!! please do not use !!!
*  |  A rotation is defined for this lattice:
d      IF ( KROTAT .GT. 0 ) THEN
d         CALL UNDRTO ( 1, UN (1), UN (2), UN (3), KROTAT )
d         RETURN
d      END IF
*  | !! end of untested part
*  |
*  +-------------------------------------------------------------------*
d      GO TO ( 5050, 5100, 5200, 5300), IRLTNO + 1
d         WRITE(LUNOUT,*)' *** Lattice geometry non supported !!! ***',
d     &                    IRLTNO
d         STOP
d 5050 CONTINUE
d      GO TO 8888
d 5100 CONTINUE
d         UN (1) = UN (1)
d         UN (2) = UN (2)
d         UN (3) =-UN (3)
d      GO TO 8888
d 5200 CONTINUE
dd         UN (1) = UN (1)
dd         UN (2) = UN (2)
dd         UN (3) = UN (3)
d      GO TO 8888
d 5300 CONTINUE
d         UN (1) = UN (1)
d         UN (2) = UN (2)
d         UN (3) =-UN (3)
d      GO TO 8888
* *********** 4,5,6 Not yet used by any run ********* *
d 8888 CONTINUE
      RETURN
*=== End of subroutine lattic =========================================*
      END