*$ 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 BASE_AGL,R,RA,AGL,AGLA,LFIRST DATA LFIRST /.TRUE./ * IF ( LFIRST ) THEN BASE_AGL = PIPIPI / 6 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 R = SQRT (XB (1) ** 2.0D+00 + XB (3) ** 2.0D+00) RA = SQRT (WB (1) ** 2.0D+00 + WB (3) ** 2.0D+00) THETA = DASIN (XB (1) / R) IF ( IRLTGG .LE. 102 ) THEN AGL = DASIN (XB (1) / R) & + (IRLTGG - 100 ) * BASE_AGL IF (WB (1) .GE. 0) THEN AGLA = DASIN (WB (1) / RA) & + (IRLTGG - 100 ) * BASE_AGL ELSE IF (WB (1) .LT. 0) THEN AGLA = DASIN (WB (1) / RA) + PIPIPI & + (IRLTGG - 100 ) * BASE_AGL ENDIF ELSE IF ( IRLTGG .LE. 104 ) THEN WRITE(LUNOUT,*)' *** alsoran test! ***' AGL = DASIN (XB (1) / R) - (IRLTGG - 200 ) * BASE_AGL IF (WB (1) .GE. 0) THEN AGLA = DASIN (WB (1) / RA) & - (IRLTGG - 200 ) * BASE_AGL ELSE IF (WB (1) .LT. 0) THEN AGLA = DASIN (WB (1) / RA) + PIPIPI & - (IRLTGG - 200 ) * BASE_AGL ENDIF ENDIF SB (1) = R * DSIN (AGL) SB (2) = XB (2) SB (3) = R * DCOS (AGL) UB (1) = RA * DSIN (AGLA) * UB (1) = WB (1) UB (2) = WB (2) UB (3) = RA * DCOS (AGLA) * UB (3) = WB (3) WRITE(LUNOUT,1001) IR,IRLTGG,BASE_AGL & ,XB(1),XB(2),XB(3),R,THETA,AGL,SB(1),SB(2),SB(3) & ,WB(1),WB(2),WB(3),RA,AGLA,UB(1),UB(2),UB(3) 1001 FORMAT(2X,'IR =',I3,/ & 2X,'IRLTGG =',I3,/ & 2X,'BASE_AGL =',E22.15,/ & 2X,'XB(1) =',E22.15,/ & 2X,'XB(2) =',E22.15,/ & 2X,'XB(3) =',E22.15,/ & 2X,'R =',E22.15,/ & 2X,'THETA = ',E22.15,/ & 2X,'AGL = ',E22.15,/ & 2X,'SB(1) =',E22.15,/ & 2X,'SB(2) =',E22.15,/ & 2X,'SB(3) =',E22.15,/ & 2X,'WB(1) =',E22.15,/ & 2X,'WB(2) =',E22.15,/ & 2X,'WB(3) =',E22.15,/ & 2X,'RA =',E22.15,/ & 2X,'AGLA = ',E22.15,/ & 2X,'UB(1) =',E22.15,/ & 2X,'UB(2) =',E22.15,/ & 2X,'UB(3) =',E22.15,/) 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