Re: FLUKA: LATTICE card
Ops
I forgot to attach...
here it is
This example is valid for different runs, according to the user
assigned lattice numbering: lattices do not need to start from 1 ,
and do not need to be contiguous ( regions do)
In this example, lattice numbers 1-5 are used by simple geometries
with only two cells, the base and its reflection or translation.
Lattices 721--> 995 are used by a geometry with rotated and
translated cells:
**********"tile" geometry : 5 modules, numbered from -2 to 2 , defined
c by a rotation around the y axis . In each module 55 cells ,
c obtained by traslation along the y axis.
C basic cell is in module 0, y position=1 , and contains approx 50
c regions
C cloned cells start from region 59 ( mod -2, y=1 ) , to region 332
c ( mod 2, y=55 ). they are ( for user choice) assigned LATTICE
c numbers from 721 to 995, with a hole for the base cell.
CCC the following two cards define the structure in the geometry
LATTICE 59.00000 168.00000 721.00000 830.00000
LATTICE 169.00000 332.00000 832.00000 995.00000
c
c
*$ 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 === *
****
****
**** do not touch the lines before
**
*** start user initialization
LOGICAL LFIRST
DIMENSION XB (3), WB (3), SB (3), UB (3), UN (3)
DIMENSION CTILE(-2:2),STILE(-2:2)
SAVE IRLSAV
SAVE CCELL, SCELL, LFIRST, CPOS, CTILE, STILE
DATA IRLSAV / -1 /
DATA LFIRST /.TRUE./
PARAMETER ( ZOR = 134.9D+00 )
PARAMETER ( TILZ = 89.0D+00 )
PARAMETER ( RTILE = 200.D+00 )
PARAMETER ( SYTILE= 1.8D+00 )
*
IF ( LFIRST ) THEN
LFIRST = .FALSE.
CPOS = TILZ - RTILE
DPHTIL = 0.1D+00
DO 11 IMOD = -2,2
PHI = -DPHTIL * IMOD
CTILE(IMOD) = COS(PHI)
STILE(IMOD) = SIN(PHI)
11 CONTINUE
END IF
* end user initialization
*
*** different lattice ranges for different geometries: choose right one
IF ( IRLTGG .NE. IRLSAV ) THEN
IF( IRLTGG .GT. 720 ) GO TO 2700
GO TO ( 50, 100, 200, 300, 400, 500 ) IRLTGG+1
* IF ( IFLAG .LT. 0 ) THEN
* IFLAG =
* END IF
WRITE(LUNOUT,*)' *** Lattice geometry non supported !!! ***'
& ,IRLTGG
STOP
50 CONTINUE
D IF ( IFLAG .EQ. 0 ) THEN
D WRITE (LUNOUT,*)
D & ' *** Lattic called with both Irltgg and Iflag = 0 ***'
D STOP 'LATTIC_1'
D END IF
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
*** 1 to 5 : simple reflections
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
* *********** 4,5,6 Not yet used by any run ********* *
400 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
500 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)
UB (3) =-WB (3)
GO TO 9999
2700 CONTINUE
************* TILES **********
*** 1st LATTICE REGION IS 721
ISYMM = ( IRLTGG - 721 )
** 55 REGIONS PER MODULE
IMOD = ISYMM / 55
** Y TRANSLATION : REFERENCE IS CELL 0
IYCELL = ISYMM - IMOD * 55
SB (2) = XB (2) - IYCELL * SYTILE
UB (2) = WB (2)
IMOD = IMOD-2
** CENTRAL MODULE IS 0
IF( IMOD .EQ. 0 ) THEN
SB (1) = XB (1)
UB (1) = WB (1)
SB (3) = XB (3)
UB (3) = WB (3)
ELSE
ZDUM = XB (3) - CPOS
XDUM = XB (1)
SB (1) = XDUM * CTILE(IMOD) + ZDUM * STILE(IMOD)
SB (3) = ZDUM * CTILE(IMOD) - XDUM * STILE(IMOD) + CPOS
UB (1) = WB (1) * CTILE(IMOD) + WB(3) * STILE(IMOD)
UB (3) = WB (3) * CTILE(IMOD) - WB(1) * STILE(IMOD)
END IF
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 ***'
STOP 'LATTIC_2'
END IF
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. 720 ) GO TO 8700
GO TO ( 5050, 5100, 5200, 5300, 5400, 5500) , 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 ********* *
5400 CONTINUE
UN (1) =-UN (1)
UN (2) = UN (2)
UN (3) = UN (3)
GO TO 8888
5500 CONTINUE
UN (1) = UN (1)
UN (2) =-UN (2)
UN (3) = UN (3)
GO TO 8888
5600 CONTINUE
UN (1) =-UN (1)
UN (2) =-UN (2)
UN (3) =-UN (3)
GO TO 8888
************* TILES **********
8700 CONTINUE
ISYMM=(IRLTNO-721)
IMOD=ISYMM/55-2
IF (IMOD .EQ. 0) GO TO 8888
UXDUM = UN (1)
UZDUM = UN (3)
UN (1) = UXDUM * CTILE(IMOD) - UZDUM * STILE(IMOD)
UN (2) = UN (2)
UN (3) = UZDUM * CTILE(IMOD) + UXDUM * STILE(IMOD)
GO TO 8888
8888 CONTINUE
*=== End of subroutine lattic =========================================*
RETURN
END
Partial thread listing: