SUBROUTINE ELECTR(IRCODE) C VERSION 4.00 -- 26 JAN 1986/1900 C****************************************************************** DOUBLE PRECISION PEIE COMMON/BOUNDS/ECUT(6),PCUT(6),VACDST *KEEP,BUFFS. COMMON /BUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,LH INTEGER MAXBUF,MAXLEN PARAMETER (MAXBUF=39*7) PARAMETER (MAXLEN=12) REAL RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF), * RUNE(MAXBUF),DATAB(MAXBUF) INTEGER LH CHARACTER*4 CRUNH,CRUNE,CEVTH,CEVTE EQUIVALENCE (RUNH(1),CRUNH), (RUNE(1),CRUNE) EQUIVALENCE (EVTH(1),CEVTH), (EVTE(1),CEVTE) *KEEP,CEREN1. COMMON /CEREN1/ CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD, * CERSIZ,LCERFI DOUBLE PRECISION CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD REAL CERSIZ LOGICAL LCERFI *KEND. COMMON/ELECIN/EKELIM,ICOMP,EKE0,EKE1,CMFP0,CMFP1,RANGE0,RANGE1, XR *0,TEFF0,BLCC,XCC,PICMP0(1),PICMP1(1),EICMP0(1),EICMP1(1),MPEEM(1), * ESIG0(500),ESIG1(500),PSIG0(500),PSIG1(500),EDEDX0(500),EDEDX1(50 *0),PDEDX0(500),PDEDX1(500),EBR10(500),EBR11(500),PBR10(500),PBR11( *500),PBR20(500),PBR21(500),TMXS0(500),TMXS1(500),CMFPE0(1),CMFPE1( *1),CMFPP0(1),CMFPP1(1),ERANG0(1),ERANG1(1),PRANG0(1),PRANG1(1),CXC *2E0(1),CXC2E1(1),CXC2P0(1),CXC2P1(1),CLXAE0(1),CLXAE1(1),CLXAP0(1) *,CLXAP1(1), THR0(1,1),THR1(1,1),THR2(1,1),THRI0(1,1),THRI1(1,1),TH *RI2(1,1),FSTEP(16),FSQR(16),MSMAP(200), VERT1(1000),VERT2(100,16), *MSTEPS,JRMAX,MXV1, MXV2,NBLC,NRNTH,NRNTHI,BLC0,BLC1,RTHR0,RTHR1,RT *HRI0,RTHRI1 *KEEP,EPCONT. COMMON/EPCONT/ EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,IDISC, * IROLD,IRNEW,RHOFAC, EOLD,ENEW,EKE,ELKE,BETA2,GLE, * TSCAT,IAUSFL DOUBLE PRECISION EDEP,RATIO REAL TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,RHOFAC,EOLD,ENEW, * EKE,ELKE,BETA2,GLE,TSCAT INTEGER IDISC,IROLD,IRNEW,IAUSFL(29) *KEND. COMMON/GEOM/ZALTIT,BOUND(6),NEWOBS,OBSLVL(10) *KEEP,LONGI. COMMON /LONGI/ APLONG,HLONG,PLONG,SPLONG,THSTEP,THSTPI, * NSTEP,LLONGI,FLGFIT DOUBLE PRECISION APLONG(0:1040,9),HLONG(0:1024),PLONG(0:1040,9), * SPLONG(0:1040,9),THSTEP,THSTPI INTEGER NSTEP LOGICAL LLONGI,FLGFIT *KEEP,MAGNET. COMMON /MAGNET/ BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT DOUBLE PRECISION BX,BZ,BVAL,BNORMC REAL BNORM,COSB,SINB,BLIMIT *KEND. COMMON /MEDIA/ NMED, RLC,RLDU,RLDUI,RHO,MSGE,MGE,MSEKE,MEKE,MLEKE, *MCMFP,MRANGE,IRAYLM,HBARO(6),HBAROI(6) CHARACTER MEDIA*24 COMMON/MEDIAC/MEDIA COMMON/MISC/KMPI,KMPO,DUNIT,NOSCAT,MED(6),RHOR(6),IRAYLR(6) DOUBLE PRECISION PRRMMU COMMON/MUON/PRRMMU,RMMU,RMMUT2 *KEEP,OBSPAR. COMMON /OBSPAR/ OBSLEV,THCKOB,XOFF,YOFF,THETAP,PHIP, * THETPR,PHIPR,NOBSLV DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10), * THETAP,THETPR(2),PHIP,PHIPR(2) INTEGER NOBSLV *KEEP,PARPAR. COMMON /PARPAR/ CURPAR,SECPAR,PRMPAR,OUTPAR,C, * E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL DOUBLE PRECISION CURPAR(14),SECPAR(14),PRMPAR(14),OUTPAR(14), * C(50),E00,E00PN,PTOT0,PTOT0N,THICKH INTEGER ITYPE,LEVL *KEND. COMMON/PATHCM/NPTH,B0PTH,B1PTH,PTH0(6),PTH1(6),PTH2(6) *KEEP,RANDPA. COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR DOUBLE PRECISION FAC,U1,U2 REAL RD(3000) INTEGER ISEED(103,10),NSEQ LOGICAL KNOR *KEEP,REJECT. COMMON /REJECT/ AVNREJ, * ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT, * FNPRIM DOUBLE PRECISION AVNREJ(10) REAL ALTMIN(10),ANEXP(10),THICKA(10),THICKD(10), * CUTLN,EONCUT LOGICAL FNPRIM *KEEP,RUNPAR. COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB, * STEPFC,NRRUN,NSHOW,PATAPE,MONIIN, * MONIOU,MDEBUG,NUCNUC, * CETAPE, * SHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE, * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE * ,GHEISH,GHESIG COMMON /RUNPAC/ DSN,HOST,USER DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB REAL STEPFC INTEGER NRRUN,NSHOW,PATAPE,MONIIN,MONIOU,MDEBUG,NUCNUC, * SHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL, * N1STTR,MDBASE INTEGER CETAPE CHARACTER*79 DSN CHARACTER*20 HOST,USER LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR, * FIX1I,FMUADD,FNKG,FPRINT,FDBASE * ,GHEISH,GHESIG *KEEP,STACKE. COMMON/STACKE/ E,TIME,X,Y,Z,U,V,W,DNEAR,IQ,IGEN,IR,IOBS,LPCTE,NP DOUBLE PRECISION E(60),TIME(60) REAL X(60),Y(60),Z(60),U(60),V(60),W(60),DNEAR(60) INTEGER IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP *KEND. COMMON/THRESH/RMT2,RMSQ,ESCD2,AP,API,AE,UP,UE,TE,THMOLL COMMON/UPHIIN/SINC0,SINC1,SIN0(20002),SIN1(20002) COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2 DOUBLE PRECISION PZERO,PRM,PRMT2,RMI,VC COMMON/USEFUL/PZERO,PRM,PRMT2,RMI,VC,RM,MEDIUM,MEDOLD,IBLOBE,ICALL COMMON/ACLOCK/NCLOCK,JCLOCK DOUBLE PRECISION THICK DATA NSTPCN/0/ C_____NCLOCK = NCLOCK+1 C_____IF (NCLOCK.GT.JCLOCK) THEN C______WRITE(MDEBUG,* )' ELECTR:NP=',NP,' IR=',IR(NP),' IOBS=',IOBS(NP) C______CALL AUSGB2 C_____END IF NEWOBS=IOBS(NP) IRCODE=1 IROLD=IR(NP) IRL=IR(NP) MEDIUM=MED(IRL) 380 CONTINUE 381 CONTINUE LELEC=5-2*IQ(NP) PEIE=E(NP) EIE=PEIE IF((EIE.LE.ECUT(IRL)))GO TO 390 MEDIUM=MED(IRL) 400 CONTINUE 401 CONTINUE IF (MEDIUM.NE.0) THEN EKE=EIE-RM ELKE=LOG(EKE) CALL RMMAR(RNNE1,1,2) IF ((RNNE1.EQ.0.0)) THEN RNNE1=1.E-30 END IF DEMFP=AMAX1(-ALOG(RNNE1),1.E-6) LELKE=EKE1*ELKE+EKE0 IF (LELEC.LT.0) THEN SIG0=ESIG1(LELKE)*ELKE+ESIG0(LELKE) ELSE SIG0=PSIG1(LELKE)*ELKE+PSIG0(LELKE) END IF END IF 450 CONTINUE 451 CONTINUE IF (MEDIUM.EQ.0) THEN TSTEP=VACDST USTEP=TSTEP TUSTEP=USTEP ELSE RHOFAC=RHOR(IRL)/RHO RHOFI=1./RHOFAC SIG=SIG0*RHOFAC IF (SIG.LE.0.0) THEN TSTEP=VACDST ELSE TSTEP=DEMFP/SIG END IF TMXS=TMXS1(LELKE)*ELKE+TMXS0(LELKE) TMXS=MIN(TMXS,STEPFC*200.*TEFF0) TMXS=TMXS*RHOFI TUSTEP=MIN(TSTEP,TMXS) IF (LELEC.LT.0) THEN DEDX0=EDEDX1(LELKE)*ELKE+EDEDX0(LELKE) ELSE DEDX0=PDEDX1(LELKE)*ELKE+PDEDX0(LELKE) END IF DEDX=RHOFAC*MIN(DEDX0,(86.65-Z(NP)*8.E-6)*RLDUI) RANGE=(EIE-ECUT(IRL)+0.001)/DEDX BETA2=MAX(1.E-8,1.-RMSQ/(EIE*EIE)) BETA3=EIE*BETA2*0.094315 TSCAT=RLDU*BETA3*BETA3 TSCAT=TSCAT*RHOFI TUSTEP=MIN(TUSTEP,0.3*TSCAT,RANGE) RATIO=TUSTEP/TSCAT USTEP=TUSTEP*(1.D0-RATIO) USTEPU=USTEP ALTEXP=EXP(-Z(NP)*HBAROI(IRL)) USTEP=USTEP*ALTEXP DISC=W(NP)*USTEP*HBAROI(IRL) IF (ABS(DISC).LT.0.065) THEN USTEP=USTEP*(1.-0.5*DISC*(1.-0.6666667*DISC* (1.-0.75*DISC * * (1.-0.8*DISC)))) ELSE IF(DISC.LE.-1.) THEN USTEP=VACDST ELSE USTEP=USTEP/DISC*LOG(DISC+1.) END IF TUSTPC=USTEP/(1.D0-RATIO) END IF IRNEW=IR(NP) IDISC=0 USTEP0=USTEP USTEP=MIN(USTEP,BLIMIT*EIE) IF((USTEP.GT.DNEAR(NP) ))CALL HOWFAR IF((IDISC.GT.0))GO TO 420 IF (USTEP.LE.0.0) THEN IF (USTEP.LT.-1.E-4) THEN WRITE(KMPO,460)USTEP 460 FORMAT(' ELECTR: NEGATIVE USTEP=',G20.10,' CM') WRITE(KMPO,470)Z(NP),DNEAR(NP),IR(NP),IRNEW,W(NP) 470 FORMAT (' Z=',G15.7, ' DNEAR=',G15.7,' IR=',I5, ' IRNEW=',I5, * ' W=',G15.7) NSTPCN=NSTPCN+1 IF (NSTPCN.GE.20) THEN CALL AUSGB2 WRITE(KMPO,480) NSTPCN 480 FORMAT (' ELECTR: PROGRAM STOPPED BECAUSE OF FREQUENT NEGA', * 'TIVE USTEP, COUNTER = ',I5) STOP END IF END IF USTEP=0. END IF IF (USTEP.EQ.0.0.OR.MEDIUM.EQ.0) THEN IF (USTEP.NE.0.0) THEN VSTEP=USTEP TVSTEP=VSTEP EDEP=PZERO TVSTPC=TVSTEP ALPHA=VSTEP*LELEC*BNORM/EIE TVSTPC=TVSTPC*(1.+0.04166667*ALPHA*ALPHA) U0=U(NP) V0=V(NP) W0=W(NP) FNORM=1.-0.5*(ALPHA*ALPHA)*(1.-0.75*(ALPHA*ALPHA)) F1SIN=(1.-FNORM)*SINB F1COS=(1.-FNORM)*COSB V1=V0*ALPHA*FNORM U(NP)=U0*(1.-F1SIN*SINB)+W0*F1SIN*COSB+V1*SINB V(NP)=FNORM*(V0-ALPHA*(U0*SINB-W0*COSB)) W(NP)=W0*(1.-F1COS*COSB)+U0*F1COS*SINB-V1*COSB RADINV=1.5-0.5*(U(NP)**2+V(NP)**2+W(NP)**2) U(NP)=U(NP)*RADINV V(NP)=V(NP)*RADINV W(NP)=W(NP)*RADINV X(NP)=X(NP)+(VSTEP*0.5)*(U0+U(NP)) Y(NP)=Y(NP)+(VSTEP*0.5)*(V0+V(NP)) ZOLD =Z(NP) Z(NP)=Z(NP)+(VSTEP*0.5)*(W0+W(NP)) TIME(NP)=TIME(NP)+TVSTPC*VC*E(NP)/SQRT((E(NP)-PRM)*(E(NP)+PRM * )) C GENERATE CERENKOV PHOTONS IF ( FNPRIM ) CALL CERENE(TVSTPC) C ADD ELECTRONS TO THE LONGITUDINAL DEVELOPMENT C FIND FIRST THE EQUIVALENT LEVELS IF ( LLONGI ) THEN C IF STARTING POINT BELOW LOWEST LEVEL THEN DON'T CHECK IF ( HLONG(NSTEP) .LE. -ZOLD ) THEN LPCT1 = LPCTE(NP) C Z NEW IS PROBABLY ONLY LITTLE BELOW Z OLD, THEREFORE INCREMENTAL SEARCH DO 6002 I1 = LPCT1,NSTEP IF ( HLONG(I1) .LT. -Z(NP) ) GOTO 6003 6002 CONTINUE I1 = NSTEP + 1 6003 CONTINUE LPCT2 = I1 - 1 DO 485 I=LPCT1,LPCT2 PLONG(I,IQ(NP)) = PLONG(I,IQ(NP)) + 1.D0 485 CONTINUE C STORE END POINT AS POSSIBLE STARTPOINT OF NEXT TRACK LPCTE(NP) = LPCT2 + 1 ENDIF ENDIF DNEAR(NP)=DNEAR(NP)-VSTEP IROLD=IR(NP) END IF IR(NP)=IRNEW IRL=IRNEW MEDIUM=MED(IRL) IF((EIE.LE.ECUT(IRL)))GO TO 390 IF (USTEP.NE.0.0) THEN IF (NEWOBS.GT.IOBS(NP)) THEN CALL AUSGAB IOBS(NP)=NEWOBS END IF END IF GO TO 401 END IF VSTEP=USTEP IF (USTEP.EQ.USTEP0) THEN TVSTEP=TUSTEP TVSTPC=TUSTPC ELSE VSTEPU=VSTEP DISC=W(NP)*VSTEPU*HBAROI(IRL) VSTEPU=VSTEPU/ALTEXP IF (ABS(DISC).LT.0.16) THEN VSTEPU=VSTEPU*(1.+.5*DISC*(1.+.33333333*DISC* (1.+0.25*DISC* * (1.+0.2*DISC)))) ELSE VSTEPU=VSTEPU/DISC*(EXP(DISC)-1.) END IF VSTP=VSTEPU/TSCAT IPTH=B0PTH+B1PTH*VSTP IF (IPTH.GT.NPTH) THEN CALL AUSGB2 WRITE(KMPO,490) VSTP,IPTH,NPTH 490 FORMAT (' ELECTR: OUT OF BOUNDS IPTH: VSTP,IPTH,NPTH=' , 1P , * G15.6,2I10) STOP END IF PTH=PTH0(IPTH)+VSTP*(PTH1(IPTH)+VSTP*PTH2(IPTH)) TVSTEP=PTH*VSTEPU TVSTPC=PTH*VSTEP END IF ALPHA=VSTEP*LELEC*BNORM/EIE TVSTPC=TVSTPC*(1.+0.04166667*ALPHA*ALPHA) DE=DEDX*TVSTEP EDEP=DE EKEF=EKE-DE EOLD=EIE ENEW=EOLD-DE CALL MSCAT U0=U(NP) V0=V(NP) W0=W(NP) FNORM=1.-0.5*(ALPHA*ALPHA)*(1.-0.75*(ALPHA*ALPHA)) F1SIN=(1.-FNORM)*SINB F1COS=(1.-FNORM)*COSB V1=V0*ALPHA*FNORM U(NP)=U0*(1.-F1SIN*SINB)+W0*F1SIN*COSB+V1*SINB V(NP)=FNORM*(V0-ALPHA*(U0*SINB-W0*COSB)) W(NP)=W0*(1.-F1COS*COSB)+U0*F1COS*SINB-V1*COSB RADINV=1.5-0.5*(U(NP)**2+V(NP)**2+W(NP)**2) U(NP)=U(NP)*RADINV V(NP)=V(NP)*RADINV W(NP)=W(NP)*RADINV X(NP)=X(NP)+(VSTEP*0.5)*(U0+U(NP)) Y(NP)=Y(NP)+(VSTEP*0.5)*(V0+V(NP)) ZOLD = Z(NP) Z(NP)=Z(NP)+(VSTEP*0.5)*(W0+W(NP)) TIME(NP)=TIME(NP)+TVSTPC*VC*E(NP)/SQRT((E(NP)-PRM)*(E(NP)+PRM)) C GENERATE CERENKOV PHOTONS IF ( FNPRIM ) CALL CERENE(TVSTPC) C ADD ELECTRONS TO THE LONGITUDINAL DEVELOPMENT C FIND FIRST THE EQUIVALENT LEVELS IF ( LLONGI ) THEN C IF STARTING POINT BELOW LOWEST LEVEL THEN DON'T CHECK IF ( HLONG(NSTEP) .LE. -ZOLD ) THEN LPCT1 = LPCTE(NP) C Z NEW IS PROBABLY ONLY LITTLE BELOW Z OLD, THEREFORE INCREMENTAL SEARCH DO 6102 I1 = LPCT1,NSTEP IF ( HLONG(I1) .LT. -Z(NP) ) GOTO 6103 6102 CONTINUE I1 = NSTEP + 1 6103 CONTINUE LPCT2 = I1 - 1 DO 495 I=LPCT1,LPCT2 PLONG(I,IQ(NP)) = PLONG(I,IQ(NP)) + 1.D0 495 CONTINUE LPCTE(NP) = LPCT2 + 1 ENDIF ENDIF DNEAR(NP)=DNEAR(NP)-VSTEP IROLD=IR(NP) CALL RMMAR(RNNO38,1,2) PHI=RNNO38*TWOPI LPHI=SINC1*PHI+SINC0 SINPHI=SIN1(LPHI)*PHI+SIN0(LPHI) CPHI=PI5D2-PHI LCPHI=SINC1*CPHI+SINC0 COSPHI=SIN1(LCPHI)*CPHI+SIN0(LCPHI) A=U(NP) B=V(NP) CC=W(NP) SINPS2=A*A+B*B IF (SINPS2.LT.1.0E-10) THEN U(NP)=SINTHE*COSPHI V(NP)=SINTHE*SINPHI W(NP)=CC*COSTHE ELSE SINPSI=SQRT(SINPS2) US=SINTHE*COSPHI VS=SINTHE*SINPHI SINDEL=B*(1./SINPSI) COSDEL=A*(1./SINPSI) U(NP)=CC*COSDEL*US-SINDEL*VS+A*COSTHE V(NP)=CC*SINDEL*US+COSDEL*VS+B*COSTHE W(NP)=-SINPSI*US+CC*COSTHE END IF RADINV=1.5-0.5*(U(NP)**2+V(NP)**2+W(NP)**2) U(NP)=U(NP)*RADINV V(NP)=V(NP)*RADINV W(NP)=W(NP)*RADINV PEIE=PEIE-EDEP EIE=PEIE E(NP)=PEIE IF((EIE.LE.ECUT(IRL)))GO TO 390 MEDOLD=MEDIUM IF (MEDIUM.NE.0) THEN EKEOLD=EKE EKE=EIE-RM ELKE=LOG(EKE) LELKE=EKE1*ELKE+EKE0 END IF IF (IRNEW.NE.IROLD) THEN IR(NP)=IRNEW IRL=IRNEW MEDIUM=MED(IRL) END IF IF((EIE.LE.ECUT(IRL)))GO TO 390 IF (NEWOBS.GT.IOBS(NP)) THEN CALL AUSGAB IOBS(NP)=NEWOBS END IF IF((IDISC.LT.0))GO TO 420 IF((MEDIUM.NE.MEDOLD))GO TO 401 DEMFP=MAX(0.,DEMFP-TVSTEP*SIG) IF(((DEMFP.LT.1.E-6)))GO TO452 GO TO 451 452 CONTINUE IF (LELEC.LT.0) THEN SIGF=ESIG1(LELKE)*ELKE+ESIG0(LELKE) ELSE SIGF=PSIG1(LELKE)*ELKE+PSIG0(LELKE) END IF CALL RMMAR(RFICT,1,2) IF(((RFICT.LE.SIGF/SIG0)))GO TO402 GO TO 401 402 CONTINUE IF ( .NOT. FNPRIM ) THEN X(1)=0. Y(1)=0. EVTH(5)=X(1) EVTH(6)=-Y(1) IF (FIX1I) THEN Z(1)=-FIXHEI NP=1 LPCTE(1)=MIN(NSTEP,INT(THICK(FIXHEI)*THSTPI)+1) SITHET=SQRT(1.D0-SECPAR(3)**2) U(1)=SITHET*COS(-SECPAR(4)) V(1)=SITHET*SIN(-SECPAR(4)) W(1)=SECPAR(3) RADINV=1.5-0.5*(U(1)**2+V(1)**2+W(1)**2) U(1)=U(1)*RADINV V(1)=V(1)*RADINV W(1)=W(1)*RADINV END IF EVTH(7)=-Z(1) CALL TOBUF(EVTH,0) C OUTPUT OF EVENTHEADER TO THE CERENKOV FILE IF (LCERFI) CALL TOBUFC(EVTH,0) CALL COORIN(DBLE(-Z(1))) TIME(1)=0.D0 FNPRIM =.TRUE. IF (FPRINT) THEN WRITE(KMPO,* )' FIRST INTERACTION AT ',EVTH(7)*0.01,' M' END IF END IF IF (LELEC.LT.0) THEN EBR1=EBR11(LELKE)*ELKE+EBR10(LELKE) CALL RMMAR(RNNO24,1,2) IF (RNNO24.LE.EBR1) THEN GO TO 500 ELSE IF (E(NP).LE.THMOLL) THEN IF((EBR1.LE.0.0))GO TO 380 GO TO 500 END IF CALL MOLLER END IF GO TO 380 END IF PBR1=PBR11(LELKE)*ELKE+PBR10(LELKE) CALL RMMAR(RNNO25,1,2) IF((RNNO25.LT.PBR1))GO TO 500 PBR2=PBR21(LELKE)*ELKE+PBR20(LELKE) IF (RNNO25.LT.PBR2) THEN CALL BHABHA ELSE CALL ANNIH GO TO 382 END IF GO TO 381 382 CONTINUE RETURN 500 CONTINUE CALL BREMS IF (IQ(NP).EQ.1) THEN RETURN ELSE GO TO 380 END IF 390 IF (EIE.GT.AE) THEN IDR=1 IF (LELEC.LT.0) THEN EDEP=PEIE-PRM ELSE EDEP=PEIE-PRM END IF ELSE IDR=2 EDEP=PEIE-PRM END IF IF (LELEC.GT.0) THEN IF (EDEP.LT.PEIE) THEN CALL RMMAR(RD,2,2) COSTHE=RD(1) FLIP=RD(2) IF((FLIP.LE.0.5))COSTHE=-COSTHE SINTHE=SQRT(MAX(0.,1.0-COSTHE*COSTHE)) E(NP)=PRM IQ(NP)=1 U(NP)=0. V(NP)=0. W(NP)=1. CALL UPHI(2,1) NP=NP+1 E(NP)=PRM IQ(NP)=1 X(NP)=X(NP-1) Y(NP)=Y(NP-1) Z(NP)=Z(NP-1) LPCTE(NP)=LPCTE(NP-1) IR(NP)=IR(NP-1) DNEAR(NP)=DNEAR(NP-1) TIME(NP)=TIME(NP-1) IGEN(NP)=IGEN(NP-1) IOBS(NP)=IOBS(NP-1) U(NP)=-U(NP-1) V(NP)=-V(NP-1) W(NP)=-W(NP-1) RETURN END IF END IF NP=NP-1 IRCODE=2 RETURN 420 IF (LELEC.LT.0) THEN EDEP=PEIE-PRM ELSE EDEP=PEIE+PRM END IF IRCODE=2 NP=NP-1 RETURN END