C program calcqecrs C IMPLICIT NONE #include #ifdef LBNEUT #include "neparm.h" #else #include "neutparams.h" #endif real*4 cost,phi,dir(3),gdir(3) INTEGER*4 IPRTBL(6) DATA IPRTBL/ 14, -14, 12, -12, 16, -16/ REAL*4 AVMASS COMMON /MASSAV/AVMASS INTEGER*4 ISIZE PARAMETER (ISIZE=5000000) REAL*4 H(ISIZE) COMMON/PAWC/H REAL EE(210) ,EE1(50) ,EE2(50) ,EE3(50) ,EE4(50), EE5(10) REAL EM(210) ,EM1(50) ,EM2(50) ,EM3(50) ,EM4(50), EM5(10) REAL ET(125) ,ET1(50) ,ET2(50) ,ET3(25) EQUIVALENCE (EE(1),EE1(1)) EQUIVALENCE (EE(51),EE2(1)) EQUIVALENCE (EE(101),EE3(1)) EQUIVALENCE (EE(151),EE4(1)) EQUIVALENCE (EE(201),EE5(1)) EQUIVALENCE (EM(1),EM1(1)) EQUIVALENCE (EM(51),EM2(1)) EQUIVALENCE (EM(101),EM3(1)) EQUIVALENCE (EM(151),EM4(1)) EQUIVALENCE (EM(201),EM5(1)) EQUIVALENCE (ET(1),ET1(1)) EQUIVALENCE (ET(51),ET2(1)) EQUIVALENCE (ET(101),ET3(1)) DATA EE1/0.025,0.075,0.125,0.175,0.225, $ 0.275,0.325,0.375,0.425,0.475, $ 0.525,0.575,0.625,0.675,0.725, $ 0.775,0.825,0.875,0.925,0.975, $ 1.025,1.075,1.125,1.175,1.225, $ 1.275,1.325,1.375,1.425,1.475, $ 1.525,1.575,1.625,1.675,1.725, $ 1.775,1.825,1.875,1.925,1.975, $ 2.025,2.075,2.125,2.175,2.225, $ 2.275,2.325,2.375,2.425,2.475/ DATA EE2/ 2.525,2.575,2.625,2.675,2.725, $ 2.775,2.825,2.875,2.925,2.975, $ 3.025,3.075,3.125,3.175,3.225, $ 3.275,3.325,3.375,3.425,3.475, $ 3.525,3.575,3.625,3.675,3.725, $ 3.775,3.825,3.875,3.925,3.975, $ 4.025,4.075,4.125,4.175,4.225, $ 4.275,4.325,4.375,4.425,4.475, $ 4.525,4.575,4.625,4.675,4.725, $ 4.775,4.825,4.875,4.925,4.975/ DATA EE3/ 5.025,5.075,5.125,5.175,5.225, $ 5.275,5.325,5.375,5.425,5.475, $ 5.525,5.575,5.625,5.675,5.725, $ 5.775,5.825,5.875,5.925,5.975, $ 6.025,6.075,6.125,6.175,6.225, $ 6.275,6.325,6.375,6.425,6.475, $ 6.525,6.575,6.625,6.675,6.725, $ 6.775,6.825,6.875,6.925,6.975, $ 7.025,7.075,7.125,7.175,7.225, $ 7.275,7.325,7.375,7.425,7.475/ DATA EE4/ 7.525,7.575,7.625,7.675,7.725, $ 7.775,7.825,7.875,7.925,7.975, $ 8.025,8.075,8.125,8.175,8.225, $ 8.275,8.325,8.375,8.425,8.475, $ 8.525,8.575,8.625,8.675,8.725, $ 8.775,8.825,8.875,8.925,8.975, $ 9.025,9.075,9.125,9.175,9.225, $ 9.275,9.325,9.375,9.425,9.475, $ 9.525,9.575,9.625,9.675,9.725, $ 9.775,9.825,9.875,9.925,9.975/ DATA EE5/ 11.00,12.00,13.00,14.00,15.00, $ 16.00,17.00,18.00,19.00,20.00/ C -- ENERGY OF MUON NEUTRINO C DATA EM1/0.025,0.075,0.125,0.175,0.225, $ 0.275,0.325,0.375,0.425,0.475, $ 0.525,0.575,0.625,0.675,0.725, $ 0.775,0.825,0.875,0.925,0.975, $ 1.025,1.075,1.125,1.175,1.225, $ 1.275,1.325,1.375,1.425,1.475, $ 1.525,1.575,1.625,1.675,1.725, $ 1.775,1.825,1.875,1.925,1.975, $ 2.025,2.075,2.125,2.175,2.225, $ 2.275,2.325,2.375,2.425,2.475/ DATA EM2/ 2.525,2.575,2.625,2.675,2.725, $ 2.775,2.825,2.875,2.925,2.975, $ 3.025,3.075,3.125,3.175,3.225, $ 3.275,3.325,3.375,3.425,3.475, $ 3.525,3.575,3.625,3.675,3.725, $ 3.775,3.825,3.875,3.925,3.975, $ 4.025,4.075,4.125,4.175,4.225, $ 4.275,4.325,4.375,4.425,4.475, $ 4.525,4.575,4.625,4.675,4.725, $ 4.775,4.825,4.875,4.925,4.975/ DATA EM3/ 5.025,5.075,5.125,5.175,5.225, $ 5.275,5.325,5.375,5.425,5.475, $ 5.525,5.575,5.625,5.675,5.725, $ 5.775,5.825,5.875,5.925,5.975, $ 6.025,6.075,6.125,6.175,6.225, $ 6.275,6.325,6.375,6.425,6.475, $ 6.525,6.575,6.625,6.675,6.725, $ 6.775,6.825,6.875,6.925,6.975, $ 7.025,7.075,7.125,7.175,7.225, $ 7.275,7.325,7.375,7.425,7.475/ DATA EM4/ 7.525,7.575,7.625,7.675,7.725, $ 7.775,7.825,7.875,7.925,7.975, $ 8.025,8.075,8.125,8.175,8.225, $ 8.275,8.325,8.375,8.425,8.475, $ 8.525,8.575,8.625,8.675,8.725, $ 8.775,8.825,8.875,8.925,8.975, $ 9.025,9.075,9.125,9.175,9.225, $ 9.275,9.325,9.375,9.425,9.475, $ 9.525,9.575,9.625,9.675,9.725, $ 9.775,9.825,9.875,9.925,9.975/ DATA EM5/ 11.00,12.00,13.00,14.00,15.00, $ 16.00,17.00,18.00,19.00,20.00/ C C -- ENERGY OF TAU NEUTRINO C DATA ET1 /.270E+01,.280E+01,.290E+01,.300E+01,.310E+01, & .320E+01,.330E+01,.340E+01,.350E+01,.360E+01, & .370E+01,.380E+01,.390E+01,.400E+01,.410E+01, & .420E+01,.430E+01,.440E+01,.450E+01,.460E+01, & .470E+01,.480E+01,.490E+01,.500E+01,.510E+01, & .520E+01,.530E+01,.540E+01,.550E+01,.560E+01, & .570E+01,.580E+01,.590E+01,.600E+01,.610E+01, & .620E+01,.630E+01,.640E+01,.650E+01,.660E+01, & .670E+01,.680E+01,.690E+01,.700E+01,.710E+01, & .720E+01,.730E+01,.740E+01,.750E+01,.760E+01/ DATA ET2 /.770E+01,.780E+01,.790E+01,.800E+01,.810E+01, & .820E+01,.830E+01,.840E+01,.850E+01,.860E+01, & .870E+01,.880E+01,.890E+01,.900E+01,.910E+01, & .920E+01,.930E+01,.940E+01,.950E+01,.960E+01, & .970E+01,.980E+01,.990E+01,.100E+02,.100E+02, & .110E+02,.120E+02,.130E+02,.140E+02,.150E+02, & .160E+02,.170E+02,.180E+02,.190E+02,.200E+02, & .210E+02,.220E+02,.230E+02,.240E+02,.250E+02, & .260E+02,.270E+02,.280E+02,.290E+02,.300E+02, & .310E+02,.320E+02,.330E+02,.340E+02,.350E+02/ DATA ET3 /.360E+02,.370E+02,.380E+02,.390E+02,.400E+02, & .410E+02,.420E+02,.430E+02,.440E+02,.450E+02, & .460E+02,.470E+02,.480E+02,.490E+02,.500E+02, & .510E+02,.520E+02,.530E+02,.540E+02,.550E+02, & .560E+02,.570E+02,.580E+02,.590E+02,.600E+02/ INTEGER*4 IPAR COMMON /COM1/IPAR REAL*4 ENERGY,PFERMI(3) COMMON /COM2/ENERGY,PFERMI REAL*4 ELCRS(3) COMMON /COM3/ELCRS INTEGER*4 LRECL,IERROR,I,J,ICYCLE PARAMETER (LRECL = 1024) EXTERNAL FNELSPAU,FNELSINT REAL*4 FNELSPAU,FNELSINT INTEGER JSTART DATA JSTART/1/ INTEGER LUNO DATA LUNO/500/ CALL ieee_handler('set','common',SIGFPE_ABORT) CALL ieee_handler('set','division',SIGFPE_ABORT) CALL ieee_handler('set','invalid',SIGFPE_ABORT) #ifdef LBNEUT write(*,*) "AVMASS=" read(*,*) AVMASS if (JSTART.eq.0) AVMASS=1.01 PARPF = 0.217 PARVF = 0.217 SWPROB= 0.25 PWPROB= 0.75 XNUMN = 8 XNUMP = 10. XNUMFP= 2. XNUMA = 16. IFLATPF = 0 #endif #ifdef USE_HBOOK CALL HLIMIT(ISIZE) CALL HROPEN(10,'CWNT','diffs.nt','N',LRECL,IERROR) IF (IERROR.ne.0) THEN WRITE(6,*) 'HROPEN:FAILED TO OPEN FILE .nt' STOP ENDIF CALL HBNT(10,'CRSSECT',' ') CALL HBNAME(10,'PARTICLE',IPAR,'kind') CALL HBNAME(10,'ENERGY',ENERGY,'energy,pfermi(3)') CALL HBNAME(10,'ELASTIC',ELCRS(1), $ 'ELSCRS1,ELSCRS2,ELSCRS3') #endif C write(*,1000) 'Particle','Energy','CRS(Orig.)', C $ 'CRS( 217 ) ','CRS( 275 )' C write(500,1000) 'Particle','Energy','CRS(Orig.)', C $ 'CRS( 217 ) ','CRS( 275 )' C 1000 FORMAT(A13,A13,A13,A13,A13) C write(*,2000) 'Particle','Energy','CRS(Orig.)' C $ ,'CRS(',parpf*1000.,')' C write(LUNO,2000) 'Particle','Energy','CRS(Orig.)' C $ ,'CRS(',parpf*1000.,')' C 2000 FORMAT(A13,A13,A13,A4,F8,A1) DO 10 I=1,6 IPAR = IPRTBL(I) DO 20 J=1,210 IF (ABS(IPAR).EQ.12) THEN ENERGY=EE(J) ELSE IF (ABS(IPAR).EQ.14) THEN ENERGY=EM(J) ELSE IF (ABS(IPAR).EQ.16) THEN IF (J.LE.125) THEn ENERGY=ET(J) ELSE GOTO 20 ENDIF ENDIF PFERMI(1)=PFMAX ELCRS(1)=FNELSPAU(ENERGY,IPAR) ELCRS(2)=FNELSINT(ENERGY,IPAR) write(*,5000) IPAR,ENERGY,ELCRS(1),ELCRS(2) write(LUNO,5000) IPAR,ENERGY,ELCRS(1),ELCRS(2) 5000 FORMAT(I13,F13.5,F13.9,F13.9) call flush(6) call flush(LUNO) #ifdef USE_HBOOK CALL HFNT(10) #endif 20 CONTINUE 10 CONTINUE #ifdef USE_HBOOK CALL HROUT(10,ICYCLE,' ') CALL HREND('CWNT') #endif cost=0.5 phi=3.14/2. dir(1)=1. dir(2)=0. dir(3)=0. call nechadir(cost,phi,dir(3),gdir(3)) END