*$ 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 Plotgeom === * * IMPLICIT DOUBLE PRECISION (A-H,O-Z) * PARAMETER ( LUNOUT = 11 ) * *----------------------------------------------------------------------* * * * Copyright (C) 1993-2011 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 08-Mar-11 by Alfredo Ferrari * * * *----------------------------------------------------------------------* * * === For FLUKA === * INCLUDE '(GLTLOC)' INCLUDE '(RTGMMV)' * === For Plotgeom === * * PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 ) * === End Plotgeom === * 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 ) * | +----------------------------------------------------------------* * | | A (positive) rotation is defined for this lattice: IF ( KROTAT .GT. 0 ) THEN SB (1) = XB (1) SB (2) = XB (2) SB (3) = XB (3) CALL DOTRSF ( 1, SB (1), SB (2), SB (3), KROTAT ) UB (1) = WB (1) UB (2) = WB (2) UB (3) = WB (3) CALL DORTNO ( 1, UB (1), UB (2), UB (3), KROTAT ) RETURN * | | * | +----------------------------------------------------------------* * | | A (negative) rotation is defined for this lattice: ELSE IF ( KROTAT .LT. 0 ) THEN SB (1) = XB (1) SB (2) = XB (2) SB (3) = XB (3) CALL UNDOTR ( 1, SB (1), SB (2), SB (3), -KROTAT ) UB (1) = WB (1) UB (2) = WB (2) UB (3) = WB (3) CALL UNDRTO ( 1, UB (1), UB (2), UB (3), -KROTAT ) RETURN END IF * | | * | +----------------------------------------------------------------* GO TO ( 50, 100, 200, 300), IRLTGG + 1 WRITE(LUNOUT,*)' *** Lattice geometry non supported !!! ***' & ,IRLTGG STOP 50 CONTINUE ****** lattice 0 : unitary transformation 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 ****** example of reflection for lattice 1 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 ****** example of translation along z for lattice 2 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 ****** example of reflection on lattice 3 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 9999 CONTINUE * ???? I do not remember if it can be activated or not! ???? * Probably no, in the present strategy the calling * routines are charged to check whether or not a call to Lattic * is required * IRLSAV = IRLTGG * | * +-------------------------------------------------------------------* * | 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 * * * *----------------------------------------------------------------------* * * Get the region index corresponding to Irltno IRCELL = IRLT ( IRLTNO - KLTCL0 + 1 ) * Get a possible rotation index for this region/lattice: KROTAT = ILTRTN ( IRCELL ) * +-------------------------------------------------------------------* * | A rotation is defined for this lattice: IF ( KROTAT .GT. 0 ) THEN CALL UNDRTO ( 1, UN (1), UN (2), UN (3), KROTAT ) RETURN * | * +-------------------------------------------------------------------* * | A (negative) rotation is defined for this lattice: ELSE IF ( KROTAT .LT. 0 ) THEN CALL DORTNO ( 1, UN (1), UN (2), UN (3), -KROTAT ) RETURN END IF * | * +-------------------------------------------------------------------* GO TO ( 5050, 5100, 5200, 5300), IRLTNO + 1 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 * *********** 4,5,6 Not yet used by any run ********* * 8888 CONTINUE RETURN *=== End of subroutine lattic =========================================* END