*$ 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