*$ CREATE LATTIC.FOR
*COPY LATTIC
*
*=== lattic ===========================================================*
*
      SUBROUTINE LATTIC ( XB, WB, DIST, SB, UB, IR, IRLTGG, IFLAG )

* === For FLUKA === *
      INCLUDE '(DBLPRC)'
      INCLUDE '(DIMPAR)'
      INCLUDE '(IOUNIT)'
* === For Morse & Plotgeom === *
*     IMPLICIT DOUBLE PRECISION (A-H,O-Z)
*
*----------------------------------------------------------------------*
*                                                                      *
*     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 26-may-98     by    Alfredo Ferrari               *
*                                                                      *
*----------------------------------------------------------------------*
*
* === For FLUKA === *
      INCLUDE '(RTGMMV)'
* === For Morse & Plotgeom === *
*     PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
*     COMMON /TAPE/ INT, LUNOUT, IDUMMY(6)
* === End Morse & Plotgeom === *
      LOGICAL LFIRST
      DIMENSION XB (3), WB (3), SB (3), UB (3), UN (3)
      SAVE DZ1,DZ2,LFIRST
      DATA LFIRST /.TRUE./
*
      IF ( LFIRST ) THEN
         DZ1 = 0.21
         DZ2 = -0.21
         LFIRST = .FALSE.
      END IF
*
*
      IF( IRLTGG .GT.  100 ) GO TO 2500
      GO TO (   50,  100,  200,  300,  400,  500,  600,  700,  800,
     &     900, 1000, 1100, 1200, 1300), IRLTGG + 1
*     *********** 4-->10 Not yet used by any run ********* *
 400  CONTINUE
 500  CONTINUE
 600  CONTINUE
 700  CONTINUE
 800  CONTINUE
 900  CONTINUE
 1000 CONTINUE
      WRITE(LUNOUT,*)' *** Lattice geometry non supported !!! ***'
     &     ,IRLTGG
      STOP
 50   CONTINUE
      SB (1) = XB (1)
      SB (2) = XB (2)
      SB (3) = XB (3)
      UB (1) = WB (1)
      UB (2) = WB (2)
      UB (3) = WB (3)
      GO TO 9999
 100  CONTINUE
      SB (1) = XB (1)
      SB (2) = XB (2)
      SB (3) =-XB (3)
      UB (1) = WB (1)
      UB (2) = WB (2)
      UB (3) =-WB (3)
      GO TO 9999
 200  CONTINUE
      SB (1) = XB (1)
      SB (2) = XB (2)
      SB (3) = XB (3) - 0.1D+00
      UB (1) = WB (1)
      UB (2) = WB (2)
      UB (3) = WB (3)
      GO TO 9999
 300  CONTINUE
      SB (1) = XB (1)
      SB (2) = XB (2)
      SB (3) =-( XB (3) - 0.15D+00 ) + 0.15D+00
      UB (1) = WB (1)
      UB (2) = WB (2)
      UB (3) =-WB (3)
      GO TO 9999
 1100 CONTINUE
      SB (1) = XB (1)
      SB (2) =-XB (2)
      SB (3) = XB (3)
      UB (1) = WB (1)
      UB (2) =-WB (2)
      UB (3) = WB (3)
      GO TO 9999
 1200 CONTINUE
      SB (1) = XB (1)
      SB (2) = XB (2)
      SB (3) = XB (3) - 40.D+00
      UB (1) = WB (1)
      UB (2) = WB (2)
      UB (3) = WB (3)
      GO TO 9999
 1300 CONTINUE
      SB (1) = XB (1)
      SB (2) =-XB (2)
      SB (3) = XB (3) - 40.D+00
      UB (1) = WB (1)
      UB (2) =-WB (2)
      UB (3) = WB (3)
      GO TO 9999
 2500 CONTINUE
      IF ( IRLTGG .LE. 102 ) THEN
         SB (1) = XB (1) - 2.0 * ( IRLTGG - 103 )
         SB (2) = XB (2)
         SB (3) = XB (3) 
         UB (1) = WB (1)
         UB (2) = WB (2)
         UB (3) = WB (3)
      ELSE IF ( IRLTGG .LE. 104 ) THEN
         SB (1) = XB (1) - 2.0 * ( IRLTGG - 102 )
         SB (2) = XB (2)
         SB (3) = XB (3) 
         UB (1) = WB (1)
         UB (2) = WB (2)
         UB (3) = WB (3)
      ELSE
          WRITE (LUNOUT,*)' NON-EXISTENT LATTICE: ',IRLTGG
          CALL FLABRT( 'LATTIC','LATTIC')
      ENDIF  
      GO TO 9999
 9999 CONTINUE
      RETURN

      ENTRY LATNOR ( UN, IRLTNO )
*
*----------------------------------------------------------------------*
*                                                                      *
*     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                          *
*                                                                      *
*----------------------------------------------------------------------*
*
      IF ( IRLTNO .GT.  100 ) GO TO 8500
      GO TO ( 5050, 5100, 5200, 5300, 5400, 5500, 5600, 5700, 5800,
     &        5900, 6000, 6100, 6200, 6300 )IRLTNO + 1
 5400 CONTINUE
 5500 CONTINUE
 5600 CONTINUE
 5700 CONTINUE
 5800 CONTINUE
 5900 CONTINUE
 6000 CONTINUE
         WRITE(LUNOUT,*)' *** Lattice geometry non supported !!! ***'
     &                   ,IRLTNO
         STOP
 5050 CONTINUE
      GO TO 8888
 5100 CONTINUE
         UN (1) = UN (1)
         UN (2) = UN (2)
         UN (3) =-UN (3)
      GO TO 8888
 5200 CONTINUE
         UN (1) = UN (1)
         UN (2) = UN (2)
         UN (3) = UN (3)
      GO TO 8888
 5300 CONTINUE
         UN (1) = UN (1)
         UN (2) = UN (2)
         UN (3) =-UN (3)
      GO TO 8888
         UN (1) = UN (1)
         UN (2) =-UN (2)
         UN (3) = UN (3)
      GO TO 8888
 6100 CONTINUE
         UN (1) = UN (1)
         UN (2) =-UN (2)
         UN (3) = UN (3)
      GO TO 8888
 6200 CONTINUE
         UN (1) = UN (1)
         UN (2) = UN (2)
         UN (3) = UN (3)
      GO TO 8888
 6300 CONTINUE
         UN (1) = UN (1)
         UN (2) =-UN (2)
         UN (3) = UN (3)
      GO TO 8888
 8500 CONTINUE
      UN (1) = UN (1)
      UN (2) = UN (2)
      UN (3) = UN (3)
      GO TO 8888
 8888 CONTINUE
      RETURN
*=== End of subroutine lattic =========================================*
      END


