! ********************************************************************** ! * ! * PROGRAM FIZCON ! * ! * PROGRAM TO CHECK PROCEDURES AND DATA IN AN ENDF-5 OR -6 FORMAT ! * EVALUATED DATA FILE ! * ! * ! * VERSION 7.0 OCTOBER 2004 C.L.DUNFORD ! * 1. MODIFIED TO PROVIDE A MODULE FOR THE NEA ! * MODLIB PROJECT ! * 2. ALLOW ENERGY DEPENDENT DELAYED FISSION ! * GROUP PARAMETERS. ! * 4. PERMIT USER TO SUPPLY BATCH INPUT FILE ! * NAME ! * 5. REMOVED FORTRAN LINE CONTROLS FROM OUTPUT ! * 6. ADDED COMMAND LINE INPUT TO UNIX AND ! * WINDOWS VERSIONS. NOTE: ONLY INPUT AND ! * OUTPUT FILE NAMES CAN BE GIVEN. DEFAULT ! * OPTIONS ARE ASSUMED UNLES THIRD ! * PARAMETER IS N. ! * VERSION 7.01 APRIL 2005 C.L.DUNFORD ! * 1. SET SUCCESS FLAG AFTER RETURN FROM BEGIN ! * 2. FIXED VALID LEVEL CHECK FOR AN ISOMER ! * 3. FIX SUBSECTION ENERGY RANGE TEST IN CKF9 ! * 4. CHANGED LOWER LIMIT ON POTENTIAL ! * SCATTERING TEST ! * 5. FIXED ERROR IN J-VALUE TEST WHEN L=0 AND I=0 ! * 6. ADDED ONE MORE SIGNIFICANT FIGURE TO UNION ! * GRID CHECK AND SUM MUP OUTPUT MESSAGES ! * 7. PARTIAL FISSION CROSS SECTIONS MT=19,20,21 ! * AND 38 DO NOT REQIRE SECONDARY ENERGY ! * DISTRIBUTIONS IN FILE 5. ! * 8. CORRECT PRODUCT TEST FOR ELASTIC SCATTERING ! * 9. MOVE POTENTIAL SCATTERING TEST TO PSYCHE. ! * VERSION 7.02 MAY 2005 C.L.DUNFORD ! * 1. FIX RESONANCE PARAMETER SUM TEST ! * ! * REFER ALL COMMENTS AND INQUIRIES TO ! * ! * NATIONAL NUCLEAR DATA CENTER ! * BUILDING 197D ! * BROOKHAVEN NATIONAL LABORATORY ! * P.O. BOX 5000 ! * UPTON, NY 11973-5000 ! * USA ! * ! * TELEPHONE 631-344-2902 ! * E-MAIL NNDC@BNL.GOV ! * !*********************************************************************** ! ! TO CUSTOMIZE THIS SOURCE RUN SETMDC ! ANS - ANSI STANDARD BATCH MODE VERSION ! VMS - COMMAND MODE FOR VMS OPERATING SYSTEM ! WIN - COMMAND MODE FOR PC USING DIGITAL VISUAL FORTRAN ! UNX - COMMAND MODE FOR UNIX USING LAHEY FORTRAN ! DVF - GRAPHICAL MODE FOR PC USING DIGITAL VISUAL FORTRAN ! LWI - GRAPHICAL MODE FOR UNIX USING LAHEY WINTERACTER ! MOD - MODULE FOR THE MODLIB PROJECT OF NEA WPEC ! ! THE "ANS" VERSION MEETS F95 STANDARDS FOR FIXED OR FREE FORMAT ! SOURCE ! THE "VMS" VERSION WILL COMPILE WITH EITHER THE FORTRAN-77 OR ! FORTRAN-90 VMS COMPILER ! THE "DVF" VERSION HAS A WINDOWS GRAPHICAL INTERFACE. IT WILL ! COMPILE WITH THE DIGITAL VISUAL FORTRAN COMPILER RUNNING ! UNDER WINDOWS ! THE "LWI" VERSION HAS A X-WINDOWS GRAPHICAL INTERFACE. IT WILL ! COMPILE WITH THE LAHEY FORTRAN COMPILER WITH WINTERACTER ! RUNNING UNDER UNIX ! !*********************************************************************** ! !+++MDC+++ !...VMS, ANS, WIN, UNX ! ! MAIN PROGRAM FOR NON-WINDOWS IMPLEMENTATION OF FIZCON ! PROGRAM FIZCON ! IMPLICIT NONE !...LWI, DVF, MOD !/! !/! MODULE IMPLEMENTATION OF FIZCON FOR MODLIB AND WINDOWS !/! !/ MODULE FIZCON !/! !/ IMPLICIT NONE !/! !/ PRIVATE !/! !/ PUBLIC :: RUN_FIZCON !/ PUBLIC :: FIZCON_INPUT, FIZCON_DATA, FIZCON_SUCCESS !...LWI, DVF !/ PUBLIC :: Default_epsiln, epsiln3, IRERUN !---MDC--- ! ! FIZCON VERSION NUMBER ! !+++MDC+++ !...VMS, UNX, ANSI, WIN, LWI, DVF CHARACTER(LEN=*), PARAMETER :: VERSION = '7.02' !...MOD !/ CHARACTER(LEN=*), PARAMETER :: VERSION = '1.0' !---MDC--- ! ! DEFINE VARIABLE PRECISION ! INTEGER(KIND=4), PARAMETER :: I4 = SELECTED_INT_KIND(8) INTEGER(KIND=4), PARAMETER :: R4 = SELECTED_REAL_KIND(6,37) INTEGER(KIND=4), PARAMETER :: R8 = SELECTED_REAL_KIND(15,307) ! REAL(KIND=R4), PARAMETER :: FACTOR=1.008665 REAL(KIND=R4), PARAMETER :: OTHIRD=1./3. ! ! STANDARD FORTRAN INPUT AND OUTPUT UNITS ! INTEGER(KIND=I4) :: NIN INTEGER(KIND=I4), PARAMETER :: INPUT0 = 5, IOUT=6 INTEGER(KIND=I4), PARAMETER :: ISCRX = 22, ISCRY = 23, ISCRXY = 24 INTEGER(KIND=I4), PARAMETER :: ISCRU1 = 25, ISCRU2 = 26 ! ! ENDF DISK FILE INPUT AND CHECKING OUTPUT FORTRAN UNITS ! INTEGER(KIND=I4), PARAMETER :: JIN=20,JOUT=21 ! ! FINAL FORTRAN OUTPUT UNIT ! INTEGER(KIND=I4) :: NOUT ! ! IMDC FLAG FOR COMPILER OPTION ! TFMT FORMAT FOR INTERACTIVE INPUT PROMPT ! STATUS PARAMETER FOR OPENING NEW FILE ! !+++MDC+++ !...ANS !/ INTEGER(KIND=I4), PARAMETER :: IMDC = 0 !/ CHARACTER(LEN=*), PARAMETER :: TFMT = ' ' !/ CHARACTER(LEN=*), PARAMETER :: OSTATUS = 'REPLACE' !...VMS !/ INTEGER(KIND=I4), PARAMETER :: IMDC = 1 !/ CHARACTER(LEN=*), PARAMETER :: TFMT = '(/A,$)' !/ CHARACTER(LEN=*), PARAMETER :: OSTATUS = 'NEW' !...WIN INTEGER(KIND=I4), PARAMETER :: IMDC = 2 CHARACTER(LEN=*), PARAMETER :: TFMT = '(/A,$)' CHARACTER(LEN=*), PARAMETER :: OSTATUS = 'REPLACE' !...UNX !/ INTEGER(KIND=I4), PARAMETER :: IMDC = 3 !/ CHARACTER(LEN=*), PARAMETER :: TFMT = '(/A,$)' !/ CHARACTER(LEN=*), PARAMETER :: OSTATUS = 'REPLACE' !...DVF !/ INTEGER(KIND=I4), PARAMETER :: IMDC = 4 !/ CHARACTER(LEN=*), PARAMETER :: TFMT = '(A)' !/ CHARACTER(LEN=*), PARAMETER :: OSTATUS = 'REPLACE' !...LWI !/ INTEGER(KIND=I4), PARAMETER :: IMDC = 5 !/ CHARACTER(LEN=*), PARAMETER :: TFMT = '(A)' !/ CHARACTER(LEN=*), PARAMETER :: OSTATUS = 'REPLACE' !...MOD !/ INTEGER(KIND=I4), PARAMETER :: IMDC = 6 !/ CHARACTER(LEN=*), PARAMETER :: TFMT = '(A)' !/ CHARACTER(LEN=*), PARAMETER :: OSTATUS = 'REPLACE' !---MDC--- ! ! COMMAND LINE INPUT TEXT AND TEXT LENGTH ! CHARACTER(LEN=100) :: INPAR INTEGER(KIND=I4) :: ILENP ! ! INPUT DATA STRUCTURE ! TYPE FIZCON_INPUT CHARACTER(LEN=100) :: INFIL CHARACTER(LEN=100) :: OUTFIL INTEGER(KIND=I4) :: MATMIN INTEGER(KIND=I4) :: MATMAX INTEGER(KIND=I4) :: ICKT INTEGER(KIND=I4) :: ISUM REAL(KIND=R4) :: EPSILN END TYPE FIZCON_INPUT ! TYPE(FIZCON_INPUT) :: FIZCON_DATA ! ! FLAG TO INDICATE WHETHER MULTIPLE INPUT FILES CAN BE SELECTED ! INTEGER(KIND=I4) :: IONEPASS ! 0, YES; 1, NO ! ! FLAG TO INDICATE SUCCESS OR FAILURE OF STANEF EXECUTION ! INTEGER(KIND=I4) :: FIZCON_SUCCESS, IRERUN ! ! END OF FILE FLAG ! INTEGER(KIND=I4) :: IFIN ! ! FILE (TAPE) LABEL FROM FIRST RECORD ! CHARACTER(LEN=66) :: TLABEL INTEGER(KIND=I4) :: LABEL ! ! LIBRARY, VERSION, SUBLIBRARY, MOD NUMBER AND FORMAT OF ! MATERIAL BEING PROCESSED ! INTEGER(KIND=I4) :: NLIB,NVER,NSUB,NMOD,NFOR ! ! MATERIAL, FILE, AND SECTION NUMBER CURRENTLY BEING PROCESSED ! INTEGER(KIND=I4) :: MATO,MFO,MTO ! ! 1000*Z + A OF MATERIAL CURRENTLY BEING PROCESSED ! AWR IS THE RATIO OF THE MATERIAL MASS TO THAT OF THE NEUTRON ! AWI IS THE RATIO OF THE PROJECTILE MASS TO THE THAT OF NEUTRON ! STA = 0.0, STABLE MATERIAL; STA = 1.0 RADIOACTIVE MATERIAL ! ELIS IS THE EXCITATION ENERGY OF THE TARGET NUCLEUS ! REAL(KIND=R4) :: ZA,AWR,AWI,STA,ELIS ! ! ENERGY LIMITS FOR THE MATERIAL ! REAL(KIND=R4), PARAMETER :: ENMIN = 1.0E-05 REAL(KIND=R4) :: ENMAX ! ! STORES MTS(SECTIONS) AND THEIR ENERGY SPANS ! INTEGER(KIND=I4), PARAMETER :: NSECMAX=1000 INTEGER(KIND=I4) :: NXC INTEGER(KIND=I4), DIMENSION(NSECMAX,2) :: INDX,ENGS ! ! LIS IS THE STATE NUMBER (0 FOR GROUND) OF THE MATERIAL ! LISO IS THE ISOMER STATE NUMBER OF THE MATERIAL ! INTEGER(KIND=I4) :: LIS,LISO ! ! LDRV IS THE DERIVED FILE FLAG ! LRP IS THE RESONANCE PARAMETER FLAG ! LFI IS THE FISSION FLAG INTEGER(KIND=I4) :: LDRV,LRP,LFI ! ! CONTENTS OF FIELDS ON A HEAD/CONT RECORD ! INTEGER(KIND=I4) :: L1H,L2H,N1H,N2H REAL(KIND=R4) :: C1H,C2H ! ! MAXIMUM SIZE OF AN INTERPOLATION TABLE ! INTEGER(KIND=I4), PARAMETER :: INTABMAX=20 ! ! CONTENTS OF FIRST RECORD AND INTERPOLATION TABLE FOR A TAB1 RECORD ! INTEGER(KIND=I4) :: L1,L2,NR,NP INTEGER(KIND=I4), DIMENSION(INTABMAX) :: NBT,JNT REAL(KIND=R4) :: C1,C2 ! ! CONTENTS OF FIRST RECORD AND INTERPOLATION TABLE FOR A TAB2 RECORD ! INTEGER(KIND=I4) :: L12,L22,NR2,NP2 INTEGER(KIND=I4), DIMENSION(INTABMAX) :: NBT2,JNT2 REAL(KIND=R4) :: C12,C22 ! ! CONTENTS OF FIRST RECORD OF A LIST RECORD ! INTEGER(KIND=I4) :: L1L,L2L,NPL,N2L REAL(KIND=R4) :: C1L,C2L ! ! POSSIBLE DATA REPETITION RATES ON A LIST RECORD ! INTEGER(KIND=I4), PARAMETER :: NREP6 = 6,NREP12 = 12 ! ! TEXT CONTENTS ON A TEXT RECORD ! CHARACTER(LEN=66) :: TEXT ! ! MATERIAL, FILE, SECTION, AND SEQUENCE NUMBER OF CURRENT RECORD ! INTEGER(KIND=I4) :: MATP,MFP,MTP,NSEQP ! ! SEQUENCE NUMBER OF THE CONT-LIKE PART OF A TAB OR LIST RECORD ! INTEGER(KIND=I4) :: NSEQP1 ! ! FLAG INDICATING WHETHER A SUMUP TEST HAS BEEN PERFORMED ! INTEGER(KIND=I4) :: ITEST ! ! SUMUP TESTS ! INTEGER(KIND=I4) :: ITFLE,IPC,NMTO INTEGER(KIND=I4), DIMENSION(250) :: MTOO ! ! TOTAL DATA STORAGE ARRAYS FOR SUMUP TESTS ! INTEGER(KIND=I4), PARAMETER :: SZDAT=50000 INTEGER(KIND=I4) :: NTOT REAL(KIND=R4), DIMENSION(SZDAT) :: XT,YT,YINT REAL(KIND=R4), DIMENSION(4,3) :: COEFS ! ! ENERGY LIMITS OF THE RESONANCE REGION ! REAL(KIND=R4) :: E1,E2 ! ! ARRAY FOR UNRESOLVED ENERGY GRID ! INTEGER(KIND=I4), PARAMETER :: NEUR=250 REAL(KIND=R4), DIMENSION(NEUR) :: EURGRID ! ! SCATTERING RADIUS CHECKING DATA ! INTEGER(KIND=I4) :: NRO REAL(KIND=R4) :: AWRI1,AWRI2 ! ! FLAG INDICATING THE PRESENCE OF FILE 3 ! INTEGER(KIND=I4) :: IFL3 ! ! FLAG IN ALL CHARGED PARTICLE ELASTICS ARE SET TO 1. ! INTEGER(KIND=I4) :: CPELAS ! ! ARRAY STORING Q-VALUES FROM FILE 3 FOR LATER TESTS ! INTEGER(KIND=I4), PARAMETER :: SZMT3=250 INTEGER(KIND=I4) :: NMT3 INTEGER(KIND=I4), DIMENSION(SZMT3) :: MT3 REAL(KIND=R4), DIMENSION(SZMT3) :: QMVAL,QVAL REAL(KIND=R4), PARAMETER :: QUNK= 7.777E+07 REAL(KIND=R4), PARAMETER :: SPIUNK= -77.777 ! ! LIGHT PARTICLE DEFINITIONS ! INTEGER(KIND=I4), PARAMETER :: NPARTS=7 INTEGER(KIND=I4), DIMENSION(NPARTS), PARAMETER :: & & IPARTS=(/0,1,1001,1002,1003,2003,2004/) REAL(KIND=R4), DIMENSION(NPARTS), PARAMETER :: & & AWPART=(/0.,1.,0.99862,1.99626,2.98960,2.98903,3.96713/) ! ! SIGNALS FOR PRESENCE OF FILES 5 AND 6 ! INTEGER(KIND=I4) :: NCKF5,NCKF6 ! ! NUMBER OF PARTIALS THAT CAN BE CHECK WITH A TOTAL FOR ! REPRESENTATION CONSISTENCY ! INTEGER(KIND=I4), PARAMETER :: SZPAR=10 ! ! DATA FOR TEST OF TOTAL FISSION AGAINST PARTIALS ! INTEGER(KIND=I4), DIMENSION(SZPAR) :: ILTFIS INTEGER(KIND=I4) :: IMTFIS,IKTFIS ! ! DATA FOR TEST OF TOTAL N,P AGAINST PARTIALS ! INTEGER(KIND=I4), DIMENSION(SZPAR) :: ILTNP INTEGER(KIND=I4) :: IMTNP,IKTNP ! ! DATA FOR TEST OF TOTAL N,A AGAINST PARTIALS ! INTEGER(KIND=I4), DIMENSION(SZPAR) :: ILTNA INTEGER(KIND=I4) :: IMTNA,IKTNA ! ! DECAY DATA CHECKING VARIABLES ! REAL(KIND=R4) :: T12,DT12 REAL(KIND=R4), PARAMETER :: EMASS=.511006E+6 ! ELECTRON MASS REAL(KIND=R4), PARAMETER :: ALPHA=1./137.04 ! FINE STRUCTURE INTEGER(KIND=I4), PARAMETER :: NDYTP=7 REAL(KIND=R4), DIMENSION(NDYTP) :: QO,DQ,BR,DBR REAL(KIND=R4) QMAX,QQ,DQQ,BE,DBE,GE,DGE,AE,DAE ! ! STORES INFOMATION ABOUT RADIOACTIVE PRODUCTS FOUND IN FILE 8 ! INTEGER(KIND=I4), PARAMETER :: SZLMF=100 INTEGER(KIND=I4) :: NLMF INTEGER(KIND=I4), DIMENSION(4,SZLMF) :: LMFS INTEGER(KIND=I4) :: NISSEC INTEGER(KIND=I4), DIMENSION(SZLMF) :: MTISO ! ! FLAG INDICATING THAT CURRENTLY PROCESSING S(ALPHA,BETA) DATA ! INTEGER(KIND=I4) :: INEGC ! ! PARAMETERS FOR THE FISSION ENERGY RELEASE TEST ! INTEGER(KIND=I4) :: MT458 REAL(KIND=R4) :: ERQ ! ! DISCRETE GAMMA RAYS SEEN IN FILES 12 AND/OR 13 ! INTEGER(KIND=I4), PARAMETER :: SZGAM=25 REAL(KIND=R4), DIMENSION(SZGAM) :: EGAM INTEGER(KIND=I4), DIMENSION(SZGAM) :: MTGAM INTEGER(KIND=I4) :: NMTGAM ! ! STORES FLAG FOR MT'S SEEN IN FILE 12 AND/OR 13 ! INTEGER(KIND=I4), PARAMETER :: SZMTS = 100 INTEGER(KIND=I4), DIMENSION(SZMTS,2) :: ICON INTEGER(KIND=I4) :: NPMT ! ! COVARAINCE TESTS INTEGER(KIND=I4), PARAMETER :: NCXMAX=25 INTEGER(KIND=I4) :: NCX, NCXLAS INTEGER(KIND=I4), DIMENSION(NCXMAX,3) :: MTLEFT REAL(KIND=R4), DIMENSION(NCXMAX,2) :: EC INTEGER(KIND=I4), PARAMETER :: MTRMAX=100 INTEGER(KIND=I4) :: MTR INTEGER(KIND=I4), DIMENSION(MTRMAX) :: MTRITE INTEGER(KIND=I4), PARAMETER :: NIXMAX=10 INTEGER(KIND=I4) :: NIX REAL(KIND=R4), DIMENSION(NIXMAX,2) :: EI INTEGER(KIND=I4), PARAMETER :: NMTMAX=100 INTEGER(KIND=I4) :: NMT33 INTEGER(KIND=I4), DIMENSION(NMTMAX,2) :: MTNI INTEGER(KIND=I4), PARAMETER :: NEGMAX=120 INTEGER(KIND=I4) :: NEG REAL(KIND=R4), DIMENSION(NEGMAX,2) :: EGR33 ! ! TAGS ON CURRENT RECORD ! INTEGER(KIND=I4) :: MAT,MF,MT,NSEQ ! ! DATA PAGING ARRAYS ! INTEGER(KIND=I4), PARAMETER :: PAGESZ = 996 INTEGER(KIND=I4) :: IPAGE INTEGER(KIND=I4) :: IPAGEX,ILOWX,IHIGHX REAL(KIND=R4) :: XP(PAGESZ) INTEGER(KIND=I4) :: IPAGEY,ILOWY,IHIGHY REAL(KIND=R4) :: YP(PAGESZ) ! ! SUMUP DATA PAGING ARRAY ! INTEGER(KIND=I4) :: IPAGEXY,ILOWXY,IHIGHXY REAL(KIND=R4) :: YTOT(PAGESZ) ! ! ERROR FLAG ! INTEGER(KIND=I4) :: IERX ! ! ERROR MESSAGE TEXT ! CHARACTER(LEN=80) :: EMESS INTEGER(KIND=I4) :: MESS INTEGER(KIND=I4), PARAMETER :: MAXMES=25 ! REAL(KIND=R4), PARAMETER :: PI=3.1415927 REAL(KIND=R4), PARAMETER :: BIGNO=1.0E+20 REAL(KIND=R4), PARAMETER :: EPSILN3=.001, EPSILN4=.0001, & & EPSILN5=.00001, EPSILN6 = .000001 REAL(KIND=R4), PARAMETER :: DEFAULT_EPSILN=EPSILN3 ! ! COGEND DATA ! INTEGER(KIND=I4) :: IDDONE,IBAV,IBREM,IUNC INTEGER(KIND=I4) :: NZ REAL(KIND=R4) :: R0,V0,W0 ! INTEGER(KIND=I4), PARAMETER :: NZMAX=100 ! REAL(KIND=R4), DIMENSION(6,NZMAX) :: XLEV DATA XLEV/0.0,0.0,0.0,0.0,0.0,0.0, & & 0.0,0.0,0.0,0.0,0.0,0.0, & & 54.75,0.0,0.0,0.0,0.0,0.0, & & 111.0,0.0,0.0,0.0,0.0,0.0, & & 188.0,0.0,4.7,4.7,0.0,0.0, & & 283.8,0.0,6.4,6.4,0.0,0.0, & & 401.6,0.0,9.2,9.2,0.0,0.0, & & 532.0,23.7,7.1,7.1,0.0,0.0, & & 685.4,31.0,8.6,8.6,0.0,0.0, & & 866.9,45.0,18.3,18.3,0.0,0.0, & & 1072.1,63.3,31.1,31.1,0.0,0.0, & & 1305.0,89.4,51.4,51.4,0.0,0.0, & & 1559.6,117.7,73.1,73.1,0.0,0.0, & & 1838.9,148.7,99.2,99.2,0.0,0.0, & & 2145.5,189.3,132.2,132.2,0.0,0.0, & & 2472.0,229.2,164.8,164.8,0.0,0.0, & & 2822.4,270.2,201.6,200.0,17.5,6.2, & & 3202.9,320.0,247.3,245.2,25.3,10.2, & & 3607.4,377.1,296.3,293.6,33.9,13.9, & & 4038.1,437.8,350.0,346.4,43.7,18.9, & & 4492.8,500.4,406.7,402.2,53.8,26.3, & & 4966.4,563.7,461.5,455.5,60.3,27.4, & & 5465.1,628.2,520.5,512.9,66.5,29.3, & & 5989.2,694.6,583.7,574.5,74.1,32.7, & & 6539.0,769.0,651.4,640.3,83.9,37.5, & & 7112.0,846.1,721.1,708.1,92.9,41.6, & & 7708.9,925.6,793.6,778.6,100.7,45.1, & & 8332.8,1008.1,871.9,854.7,111.8,51.0, & & 8978.9,1096.1,951.0,931.1,119.8,54.0, & & 9658.6,1193.6,1042.8,1019.7,135.9,65.1, & & 10367.1,1297.7,1142.3,1115.4,158.1,80.5, & & 11103.2,1414.3,1247.8,1216.7,180.0,97.2, & & 11866.7,1526.5,1358.6,1323.1,203.5,115.0, & & 12657.8,1653.9,1476.2,1435.8,231.5,135.0, & & 13473.7,1782.0,1596.0,1549.9,256.5,153.0, & & 14325.6,1921.0,1727.2,1674.9,292.1,181.0, & & 15199.7,2065.1,1863.9,1804.4,322.1,206.0, & & 16104.6,2216.3,2006.8,1939.6,357.5,235.0, & & 17038.4,2372.5,2155.5,2080.0,393.6,264.0, & & 17997.6,2531.6,2306.7,2222.3,430.3,293.0, & & 18985.6,2697.7,2464.7,2370.5,468.4,323.0, & & 19999.5,2865.5,2625.1,2520.2,504.6,353.0, & & 21044.0,3042.5,2793.2,2676.9,544.0,385.0, & & 22117.2,3224.0,2966.9,2837.9,585.0,418.0, & & 23219.9,3411.9,3146.1,3003.8,627.1,453.0, & & 24350.3,3604.3,3330.3,3173.3,669.9,487.0, & & 25514.0,3805.8,3523.7,3351.1,717.5,526.0, & & 26711.2,4018.0,3727.0,3537.5,770.2,570.0, & & 27939.9,4237.5,3938.0,3730.1,825.6,617.0, & & 29200.1,4464.7,4156.1,3928.8,883.8,667.0, & & 30491.2,4698.3,4380.4,4132.2,943.7,717.0, & & 31813.8,4939.2,4612.0,4341.4,1006.0,770.0, & & 33169.4,5188.1,4852.1,4557.1,1072.1,826.0, & & 34561.4,5452.8,5103.7,4782.2,1145.0,889.0, & & 35984.6,5714.3,5359.4,5011.9,1217.1,949.0, & & 37440.6,5988.8,5623.6,5247.0,1292.8,1014.0, & & 38924.6,6266.3,5890.6,5482.7,1361.3,1074.0, & & 40443.0,6548.8,6164.2,5723.4,1434.6,1135.0, & & 41990.6,6834.8,6440.4,5964.3,1511.0,1195.0, & & 43568.9,7126.0,6721.5,6207.9,1575.3,1251.0, & & 45184.0,7427.9,7012.8,6459.3,1650.0,1311.0, & & 46834.2,7736.8,7311.8,6716.2,1722.8,1374.0, & & 48519.0,8052.0,7617.1,6976.9,1800.0,1437.0, & & 50239.1,8375.6,7930.3,7242.8,1880.8,1503.0, & & 51995.7,8708.0,8251.6,7514.0,1967.5,1573.0, & & 53788.5,9045.8,8580.6,7790.1,2046.8,1638.0, & & 55617.7,9394.2,8917.8,8071.1,2128.3,1707.0, & & 57485.5,9751.3,9264.3,8357.9,2206.5,1777.0, & & 59389.6,10115.1,9616.9,8648.0,2306.8,1853.0, & & 61332.3,10486.4,9978.2,8943.6,2398.1,1925.0, & & 63313.8,10870.4,10348.6,9244.1,2491.2,2001.0, & & 65350.8,11270.7,10739.4,9560.7,2600.9,2090.0, & & 67416.4,11681.6,11136.1,9881.1,2708.0,2180.0, & & 69525.0,12099.8,11544.0,10206.8,2819.6,2271.0, & & 71676.4,12526.7,11958.7,10535.3,2931.7,2362.0, & & 73870.8,12968.0,12385.0,10870.9,3048.5,2458.0, & & 76111.0,13418.5,12824.1,11215.2,3173.7,2558.0, & & 78394.8,13879.9,13272.6,11563.7,3296.0,2658.0, & & 80724.9,14352.8,13733.6,11918.7,3424.9,2763.0, & & 83102.3,14839.3,14208.7,12283.9,3561.6,2873.0, & & 85530.4,15346.7,14697.9,12657.5,3704.1,2990.0, & & 88004.5,15860.8,15200.0,13035.2,3850.7,3108.0, & & 90525.9,16387.5,15711.1,13418.6,3999.1,3228.0, & & 93105.0,16939.3,16244.3,13813.8,4149.4,3357.0, & & 95729.9,17493.0,16784.7,14213.5,4317.0,3489.0, & & 98404.0,18049.0,17337.1,14619.4,4482.0,3619.0, & & 101137.0,18639.0,17906.5,15031.2,4652.0,3756.0, & & 103921.9,19236.7,18484.3,15444.4,4822.0,3891.0, & & 106755.3,19840.0,19083.2,15871.0,5002.0,4031.0, & & 109650.9,20472.1,19693.2,16300.3,5182.3,4176.0, & & 112601.4,21104.6,20313.7,16733.1,5366.9,4319.0, & & 115606.1,21757.4,20947.6,17166.3,5548.0,4463.0, & & 118678.0,22426.8,21600.5,17610.0,5723.2,4608.0, & & 121818.0,23097.2,22266.2,18056.8,5932.9,4756.0, & & 125027.0,23772.9,22944.0,18504.1,6120.5,4859.0, & & 128220.0,24460.0,23779.0,18930.0,6288.0,5036.0, & & 131590.0,25275.0,24385.0,19452.0,6556.0,5236.0, & & 135960.0,26110.0,25250.0,19930.0,6754.0,5394.0, & & 139490.0,26900.0,26020.0,20410.0,6977.0,5561.0, & & 143090.0,27700.0,26810.0,20900.0,7205.0,5732.0/ REAL(KIND=R4), DIMENSION(4,NZMAX) :: RDENS DATA RDENS/ & & 0.0,0.0,0.0,0.0, & & 0.0,0.0,0.0,0.0, & & 0.0,0.0,0.0,0.0, & & 0.0,0.0,0.0,0.0, & & 0.0405,0.00008,0.0,0.0, & & 0.0493,0.00018,0.0,0.0, & & 0.0541,0.00024,0.00024,0.0, & & 0.0564,0.00032,0.00063,0.0, & & 0.0577,0.00041,0.00122,0.0, & & 0.0584,0.00053,0.00207,0.0, & & 0.0627,0.00069,0.00268,0.018, & & 0.0666,0.00088,0.00339,0.037, & & 0.0699,0.00108,0.00417,0.048, & & 0.0729,0.00131,0.00498,0.063, & & 0.0756,0.00155,0.00586,0.079, & & 0.0781,0.00181,0.00682,0.093, & & 0.0804,0.00209,0.00784,0.103, & & 0.0824,0.00240,0.00891,0.110, & & 0.0844,0.00272,0.0100,0.128, & & 0.0862,0.00306,0.0112,0.144, & & 0.0879,0.00343,0.0125,0.148, & & 0.0896,0.00382,0.0138,0.150, & & 0.0910,0.00424,0.0151,0.152, & & 0.0924,0.00467,0.0165,0.147, & & 0.0938,0.00512,0.0180,0.154, & & 0.0950,0.00560,0.0194,0.155, & & 0.0962,0.00610,0.0210,0.156, & & 0.0974,0.00663,0.0225,0.156, & & 0.0985,0.00717,0.0241,0.152, & & 0.0995,0.00774,0.0258,0.158, & & 0.1006,0.00834,0.0274,0.162, & & 0.1015,0.00895,0.0291,0.166, & & 0.1026,0.00958,0.0308,0.172, & & 0.1035,0.0102,0.0325,0.177, & & 0.1043,0.0109,0.0343,0.182, & & 0.1053,0.0116,0.0361,0.187, & & 0.1063,0.0124,0.0379,0.193, & & 0.1071,0.0131,0.0396,0.199, & & 0.1080,0.0139,0.0414,0.206, & & 0.1089,0.0147,0.0432,0.210, & & 0.1098,0.0156,0.0450,0.213, & & 0.1107,0.0164,0.0469,0.216, & & 0.1115,0.0173,0.0487,0.219, & & 0.1124,0.0183,0.0505,0.222, & & 0.1133,0.0192,0.0523,0.225, & & 0.1142,0.0202,0.0540,0.228, & & 0.1150,0.0212,0.0558,0.223, & & 0.1159,0.0222,0.0576,0.238, & & 0.1168,0.0233,0.0593,0.241, & & 0.1178,0.0244,0.0610,0.246, & & 0.1187,0.0255,0.0627,0.249, & & 0.1196,0.0267,0.0644,0.253, & & 0.1205,0.0278,0.0661,0.257, & & 0.1215,0.0291,0.0679,0.261, & & 0.1224,0.0303,0.0693,0.266, & & 0.1234,0.0316,0.0708,0.271, & & 0.1244,0.0329,0.0722,0.274, & & 0.1254,0.0343,0.0739,0.277, & & 0.1264,0.0357,0.0752,0.279, & & 0.1275,0.0371,0.0767,0.281, & & 0.1285,0.0386,0.0780,0.284, & & 0.1296,0.0401,0.0794,0.286, & & 0.1306,0.0417,0.0807,0.288, & & 0.1317,0.0433,0.0819,0.290, & & 0.1328,0.0449,0.0831,0.292, & & 0.1340,0.0466,0.0842,0.294, & & 0.1351,0.0483,0.0853,0.296, & & 0.1362,0.0501,0.0864,0.298, & & 0.1374,0.0519,0.0871,0.300, & & 0.1386,0.0538,0.0883,0.303, & & 0.1398,0.0557,0.0892,0.305, & & 0.1410,0.0577,0.0900,0.308, & & 0.1423,0.0597,0.0908,0.310, & & 0.1436,0.0618,0.0916,0.313, & & 0.1448,0.0639,0.0922,0.315, & & 0.1462,0.0661,0.0929,0.318, & & 0.1475,0.0684,0.0934,0.320, & & 0.1489,0.0707,0.0939,0.323, & & 0.1502,0.0730,0.0943,0.326, & & 0.1517,0.0755,0.0948,0.329, & & 0.1531,0.0780,0.0954,0.331, & & 0.1546,0.0806,0.0954,0.334, & & 0.1561,0.0833,0.0956,0.337, & & 0.1576,0.0860,0.0958,0.341, & & 0.1591,0.0888,0.0959,0.344, & & 0.1607,0.0917,0.0960,0.347, & & 0.1623,0.0947,0.0959,0.350, & & 0.1639,0.0978,0.0955,0.353, & & 0.1656,0.1010,0.0954,0.356, & & 0.1673,0.1042,0.0954,0.359, & & 0.1690,0.1076,0.0953,0.361, & & 0.1708,0.1111,0.0952,0.364, & & 0.1726,0.1147,0.0946,0.367, & & 0.1744,0.1184,0.0941,0.370, & & 0.1763,0.1222,0.0936,0.374, & & 0.1782,0.1262,0.0931,0.377, & & 0.1802,0.1303,0.0924,0.380, & & 0.1829,0.1345,0.0917,0.384, & & 0.186,0.140,0.0910,0.388,0.189,0.145,0.0903,0.392/ REAL(KIND=R4), DIMENSION(3,NZMAX) :: BX DATA BX/ & & 0.0,0.0,0.0, & & 0.0,0.0,0.0, & & 0.0,0.0,0.0, & & 0.0,0.0,0.0, & & 0.0,0.0,0.0, & & 0.938,0.0,0.0, & & 0.948,1.475,0.0, & & 0.958,1.405,0.0, & & 0.964,1.360,0.0, & & 0.969,1.309,0.0, & & 0.973,1.283,0.0, & & 0.974,1.248,0.0, & & 0.975,1.212,0.0, & & 0.976,1.186,0.921, & & 0.977,1.169,0.929, & & 0.978,1.154,0.935, & & 0.979,1.143,0.940, & & 0.980,1.132,0.944, & & 0.981,1.120,0.946, & & 0.982,1.113,0.948, & & 0.982,1.101,0.947, & & 0.982,1.096,0.950, & & 0.983,1.091,0.953, & & 0.984,1.088,0.956, & & 0.985,1.085,0.958, & & 0.985,1.080,0.960, & & 0.986,1.078,0.962, & & 0.986,1.076,0.964, & & 0.986,1.072,0.965, & & 0.987,1.070,0.967, & & 0.987,1.069,0.968, & & 0.988,1.067,0.969, & & 0.988,1.064,0.970, & & 0.988,1.062,0.971, & & 0.981,1.060,0.971, & & 0.989,1.059,0.972, & & 0.989,1.057,0.973, & & 0.990,1.053,0.973, & & 0.990,1.051,0.974, & & 0.990,1.050,0.974, & & 0.990,1.048,0.975, & & 0.990,1.046,0.975, & & 0.990,1.045,0.976, & & 0.990,1.043,0.976, & & 0.991,1.042,0.976, & & 0.991,1.041,0.977, & & 0.991,1.040,0.977, & & 0.991,1.039,0.977, & & 0.990,1.038,0.978, & & 0.991,1.037,0.978, & & 0.991,1.036,0.978, & & 0.991,1.035,0.979, & & 0.991,1.034,0.979, & & 0.991,1.033,0.979, & & 0.992,1.032,0.979, & & 0.992,1.032,0.979, & & 0.992,1.031,0.980, & & 0.992,1.030,0.980, & & 0.992,1.030,0.980, & & 0.992,1.029,0.980, & & 0.992,1.028,0.980, & & 0.992,1.028,0.980, & & 0.992,1.028,0.980, & & 0.992,1.027,0.980, & & 0.992,1.027,0.981, & & 0.992,1.027,0.981, & & 0.992,1.026,0.981, & & 0.992,1.026,0.981, & & 0.992,1.026,0.981, & & 0.992,1.025,0.981, & & 0.992,1.025,0.981, & & 0.992,1.024,0.981, & & 0.992,1.024,0.981, & & 0.992,1.024,0.982, & & 0.992,1.024,0.982, & & 0.992,1.024,0.982, & & 0.992,1.023,0.982, & & 0.992,1.023,0.982, & & 0.992,1.022,0.982, & & 0.992,1.022,0.982, & & 0.992,1.022,0.982, & & 0.992,1.022,0.982, & & 0.992,1.022,0.982, & & 0.992,1.022,0.982, & & 0.992,1.021,0.982, & & 0.992,1.021,0.982, & & 0.992,1.021,0.982, & & 0.992,1.021,0.982, & & 0.992,1.021,0.982, & & 0.992,1.021,0.982, & & 0.992,1.021,0.982, & & 0.992,1.021,0.982, & & 0.992,1.021,0.982, & & 0.992,1.021,0.982, & & 0.992,1.021,0.982, & & 0.992,1.021,0.982, & & 0.992,1.021,0.982, & & 0.992,1.021,0.982, & & 0.992,1.021,0.982,0.992,1.021,0.982/ ! !*********************************************************************** ! !+++MDC+++ !...VMS, ANS, WIN, UNX ! CALL RUN_FIZCON ! ! TERMINATE JOB ! IF(FIZCON_SUCCESS.EQ.0) THEN WRITE(IOUT,'(/A)') ' ' STOP ' JOB COMPLETED SUCCESSFULLY' ELSE WRITE(IOUT,'(/A)') ' ' STOP ' JOB TERMINATED' END IF !---MDC--- ! CONTAINS ! !*********************************************************************** ! SUBROUTINE RUN_FIZCON ! ! EXECUTES FIZCON PROCESS ! CHARACTER(LEN=80) :: IFIELD INTEGER(KIND=I4) :: IQUIT ! FLAG TO INDICATE WHETHER OR NOT TO EXIT INTEGER(KIND=I4) :: IFIND ! FLAGS WHETHER DESIRED MATERIAL FOUND INTEGER(KIND=I4) :: MFN INTEGER(KIND=I4) :: MATT,MFT,MTT,NSEQT,NSEQB INTEGER(KIND=I4) :: I ! CHARACTER(LEN=*), PARAMETER :: DASHES = REPEAT('-',80) ! ! OUTPUT PROGRAM IDENTIFICATION ! FIZCON_SUCCESS = 0 IF(IMDC.LT.4) THEN WRITE(IOUT,'(/2A)') ' PROGRAM FIZCON VERSION ',VERSION END IF ! ! CHECK FOR COMMAND LINE INPUT (VMS ONLY) ! IONEPASS = 0 CALL GET_FROM_CLINE ! ! INITIALIZE RUN ! 10 CALL BEGIN(IQUIT) IF(IQUIT.GT.0) THEN IF(IONEPASS.EQ.1) FIZCON_SUCCESS = 1 GO TO 100 END IF ! ! CHECK LABEL AND FIND STARTING MATERIAL ! CALL SEARCH(IFIND) IF(IFIND.EQ.0) GO TO 50 ! ! UNEXPECTED END OF FILE ENCOUNTERED ! 20 IF(IERX.EQ.2) THEN IF(IMDC.LT.4) THEN WRITE(IOUT,'(//5X,2A)') 'END OF FILE ENCOUNTERED BEFORE ', & & 'TEND RECORD FOUND!' END IF IF(NOUT.NE.IOUT) THEN WRITE(NOUT,'(//5X,2A)') 'END OF FILE ENCOUNTERED BEFORE ', & & 'TEND RECORD FOUND!' END IF IF(NOUT.NE.IOUT) CLOSE(UNIT=NOUT) CLOSE(UNIT=JIN) FIZCON_SUCCESS = 1 GO TO 100 END IF ! ! PROCESS NEXT SECTION ! IF(MAT.NE.MATO) THEN !NEW MATERIAL IF(FIZCON_DATA%MATMAX.NE.0.AND.MAT.GT.FIZCON_DATA%MATMAX) & & GO TO 70 NSEQP1 = NSEQP MATO = MAT MFO = 0 IFL3 = 0 E1 = BIGNO E2 = 0. NPMT = 0 NMT3 = 0 NLMF = 0 NMTGAM = 0 NISSEC = 0 NCKF5 = 0 NCKF6 = 0 REWIND (UNIT=ISCRX) REWIND (UNIT=ISCRY) REWIND (UNIT=ISCRXY) REWIND (UNIT=ISCRU1) REWIND (UNIT=ISCRU2) WRITE(NOUT,'(A/3X,A,I5)') CHAR(12),'CHECK MATERIAL',MAT WRITE(NOUT,'(19X,A)') & & '(NO ERRORS DETECTED IN SECTIONS WITHOUT COMMENTS)' IF(NOUT.NE.IOUT) THEN IF(IMDC.LT.4) WRITE(IOUT,'(/A)') ' ' END IF END IF IF(MF.NE.MFO) THEN WRITE(NOUT,'(/A/A,I2)') DASHES,'FILE ',MF MFO = MF IF(MF.GE.31) THEN NCX = 0 NCXLAS = 0 MTR = 0 NEG = 0 NMT33 = 0 END IF END IF ! ! NEW SECTION ! 30 WRITE(NOUT,'(3X,A,I3)') 'SECTION ',MT MTO = MT ! ! IN INTERACTIVE MODE OUTPUT CURRENT SECTION ID TO TERMINAL ! IF(NOUT.NE.IOUT) CALL OUT_STATUS ! ! CHECK THE NEW SECTION ! CALL CHKSEC IF(IERX.EQ.2) GO TO 20 ! ! IF FATAL ERROR FOUND, SKIP REST OF SECTION ! 35 IF(IERX.NE.0) THEN IERX = 2 NSEQB = NSEQ DO WHILE (MT.NE.0) READ(JIN,'(A)',END=20) IFIELD READ(IFIELD,'(66X,I4,I2,I3,I5)',ERR=40) MAT,MF,MT,NSEQ 40 CONTINUE END DO WRITE(EMESS,'(A,I3,A,I4,2A,I6,A,I6)') & & 'MF=',MFO,' MT=',MTO,' CAN NOT BE CHECKED FROM SEQUENCE ', & & 'NUMBER ',NSEQB,' TO',NSEQ CALL ERROR_MESSAGE(0) IERX = 0 END IF ! ! READ UNTIL HEAD OR TEND RECORD FOUND ! 50 IF(MAT.GE.0) THEN 55 CALL RDHEAD(I) IF(IERX.GE.1) GO TO 35 IF(I.GT.1.AND.I.LT.5) THEN GO TO 55 ELSE IF(I.EQ.5) THEN IFIN = 1 END IF ELSE GO TO 100 END IF ! ! END OF FILE SUM UP TESTS ! IF(MF.NE.MFO.OR.IFIN.NE.0) THEN IF(ITEST.GT.0) THEN MATT = MAT MFT = MF MTT = MT NSEQT = NSEQ IF(MFO.EQ.1) THEN EMESS = ' ' CALL ERROR_MESSAGE(0) EMESS = 'SUMUP TEST RESULTS' CALL ERROR_MESSAGE(0) CALL SUM452(0) ELSE IF(MFO.EQ.3) THEN EMESS = ' ' CALL ERROR_MESSAGE(0) EMESS = 'SUMUP TEST RESULTS' CALL ERROR_MESSAGE(0) CALL SUMF3(0) ELSE IF(MFO.EQ.23) THEN EMESS = ' ' CALL ERROR_MESSAGE(0) EMESS = 'SUMUP TEST RESULTS' CALL ERROR_MESSAGE(0) CALL SUMGAM(0) END IF ITEST = 0 MAT = MATT MF = MFT MT = MTT NSEQ = NSEQT END IF ! ! CHECK FOR MISSING SECTIONS ! IF(IFIN.EQ.1.OR.MAT.NE.MATO) THEN MFN = 100 ELSE MFN = MF - 1 END IF CALL EFTEST(MFO,MFN) END IF ! ! CHECK END OF TAPE FLAG ! IF(IFIN.EQ.0) THEN IF(FIZCON_DATA%MATMAX.EQ.0.OR.MAT.LE.FIZCON_DATA%MATMAX) & & GO TO 20 END IF ! ! CLOSE FILES ! 70 IF(NOUT.NE.IOUT) CLOSE(UNIT=NOUT) CLOSE(UNIT=JIN) CLOSE(UNIT=ISCRX,STATUS='DELETE') CLOSE(UNIT=ISCRY,STATUS='DELETE') CLOSE(UNIT=ISCRXY,STATUS='DELETE') CLOSE(UNIT=ISCRU1,STATUS='DELETE') CLOSE(UNIT=ISCRU2,STATUS='DELETE') ! ! SEE IF ONE PASS LIMIT SET ! IF(IONEPASS.EQ.0) GO TO 10 100 RETURN END SUBROUTINE RUN_FIZCON ! !*********************************************************************** ! SUBROUTINE BEGIN(IQUIT) ! ! ROUTINE TO SET UP JOB ! IMPLICIT NONE ! INTEGER(KIND=I4) :: IQUIT ! CHARACTER(LEN=*), INTRINSIC :: TRIM CHARACTER(LEN=1), INTRINSIC :: CHAR INTEGER(KIND=I4), INTRINSIC :: ICHAR ! CHARACTER(LEN=4) :: BUF1 CHARACTER(LEN=12) :: BUF2 CHARACTER(LEN=1) :: IW CHARACTER(LEN=11) :: ADATE CHARACTER(LEN=50) :: MATSIN LOGICAL(KIND=I4) :: IEXIST INTEGER(KIND=I4) :: IC REAL(KIND=R4) :: EPS ! ! INITIALIZE PROCESSING CONTROL VARIABLES ! IERX = 0 MATO = 0 MFO = 0 MTO = 0 IFIN = 0 IBAV = 2 IBREM = 1 IUNC = 1 ITEST = 0 IDDONE = 0 NOUT = IOUT 10 IQUIT = 0 ! ! INITIALIZE TO STANDARD OPTIONS ! IF(IMDC.LT.4) THEN FIZCON_DATA%INFIL = '*' FIZCON_DATA%OUTFIL = '*' FIZCON_DATA%MATMIN = 0 FIZCON_DATA%MATMAX = 0 FIZCON_DATA%ICKT = 1 FIZCON_DATA%ISUM = 0 FIZCON_DATA%EPSILN = DEFAULT_EPSILN END IF SELECT CASE (IMDC) CASE (0) IW = 'N' IONEPASS = 0 CASE(1,2,3) IF(ILENP.NE.0) THEN CALL TOKEN(INPAR,'%',1,FIZCON_DATA%INFIL) CALL TOKEN(INPAR,'%',2,FIZCON_DATA%OUTFIL) CALL TOKEN(INPAR,'%',3,IW) IC = ICHAR(IW) IF(IC.GT.96.AND.IC.LT.123) IW = CHAR(IC-32) IF(IW.EQ.' ') THEN IW = 'Y' ELSE IF(IW.NE.'Y'.AND.IW.NE.'N') THEN IW = '*' END IF IONEPASS = 1 ELSE IW = '*' IONEPASS = 0 END IF CASE (4,5,6) IW = 'N' IONEPASS = 1 END SELECT ! ! GET INPUT FILE SPECIFICATION ! IF(IMDC.LT.4) THEN IF(FIZCON_DATA%INFIL.EQ.'*') THEN IF(IMDC.NE.0) THEN WRITE(IOUT,FMT=TFMT) & & ' Input File Specification - ' END IF READ(NIN,'(A)') FIZCON_DATA%INFIL ELSE WRITE(IOUT,'(/2A)') ' Input file - ', & & TRIM(FIZCON_DATA%INFIL) END IF END IF ! ! SEE IF INPUT INDICATES FILE TERMINATION ! IF(FIZCON_DATA%INFIL.EQ.' '.OR.FIZCON_DATA%INFIL.EQ.'DONE') THEN IQUIT = 1 GO TO 100 END IF ! ! MAKE SURE INPUT FILE EXISTS ! INQUIRE(FILE=FIZCON_DATA%INFIL,EXIST=IEXIST) IF(.NOT.IEXIST) THEN IF(IMDC.LT.4) THEN WRITE(IOUT,'(/A/)') ' COULD NOT FIND INPUT FILE' END IF SELECT CASE (IMDC) CASE (1,2,3) IF(IONEPASS.EQ.0) GO TO 10 END SELECT IQUIT = 1 FIZCON_SUCCESS = 1 GO TO 100 END IF ! ! GET OUTPUT FILE SPECIFICATION ! IF(IMDC.LT.4) THEN IF(FIZCON_DATA%OUTFIL.EQ.'*' ) THEN IF(IMDC.NE.0) THEN WRITE(IOUT,FMT=TFMT) & & ' Output Message File Specification - ' END IF READ(NIN,'(A)') FIZCON_DATA%OUTFIL ELSE WRITE(IOUT,'(/2A)') ' Output file - ', & & TRIM(FIZCON_DATA%OUTFIL) END IF END IF IF(FIZCON_DATA%OUTFIL.NE.' ') THEN NOUT = JOUT ! SETS FORTRAN OUTPUT UNIT IF DISK FILE END IF ! ! CHECK FOR STANDARD OPTIONS ! IF(IW.EQ.'*') THEN IF(IMDC.GE.1.AND.IMDC.LE.3) THEN 15 WRITE(IOUT,FMT=TFMT) ' Standard Options (Y(es),N(o),?)? ' READ(NIN,'(A)') IW IC = ICHAR(IW) IF(IC.GT.96.AND.IC.LT.123) IW = CHAR(IC-32) IF(IW.EQ.'?') THEN IW = '*' WRITE(IOUT,20) 20 FORMAT(10X,' STANDARD OPTIONS ARE'/ & & 10X,' CHECK ENTIRE TAPE'/ & & 10X,' OMIT DEVIANT POINT CHECK'/ & & 10X,' OMIT SUM UP TESTS '/ & & 10X,' EPSILON = .001 ') GO TO 15 END IF END IF END IF ! ! GET USER OPTION CHOICE WHEN NOT STANDARD ! IF(IMDC.EQ.0.OR.(IW.EQ.'N'.AND.IMDC.LT.4)) THEN ! ! MATERIAL NUMBER RANGE SELECTION ! CALL SELECT_MATS(MATSIN) ! ! DEVIANT POINT TEST? ! IF(IMDC.EQ.0) THEN CALL TOKEN(MATSIN,',',3,BUF1) IW = BUF1(1:1) ELSE WRITE(IOUT,FMT=TFMT) & & ' Deviant Point Check (Y(es),N(o))? - ' END IF READ(NIN,'(A)') IW IC = ICHAR(IW) IF(IC.GT.96.AND.IC.LT.123) IW = CHAR(IC-32) IF(IW.EQ.'Y') FIZCON_DATA%ICKT = 0 ! ! SUM UP TESTS? ! IF(IMDC.EQ.0) THEN CALL TOKEN(MATSIN,',',4,BUF1) IW = BUF1(1:1) ELSE WRITE(IOUT,FMT=TFMT) & & ' Sum Up Tests (Y(es),N(o))? - ' END IF READ(NIN,'(A)') IW IC = ICHAR(IW) IF(IC.GT.96.AND.IC.LT.123) IW = CHAR(IC-32) ! ! SUM UP TESTS SELECTED, GET THE EPSILON TOLERANCE ! IF(IW.EQ.'Y') THEN FIZCON_DATA%ISUM = 1 IF(IMDC.EQ.0) THEN CALL TOKEN(MATSIN,',',5,BUF2) READ(BUF2,'(BN,E12.5)',ERR=45) EPS GO TO 50 45 EPS = 0.0 ELSE WRITE(IOUT,FMT=TFMT) ' Enter Epsilon - ' READ(NIN,'(E12.5)',ERR=50) EPS END IF 50 IF(EPS.EQ.0.) EPS = DEFAULT_EPSILN FIZCON_DATA%EPSILN = EPS END IF END IF ! ! OPEN INPUT AND OUTPUT FILES ! OPEN(UNIT=JIN,ACCESS='SEQUENTIAL',STATUS='OLD', & & FILE=FIZCON_DATA%INFIL,ACTION='READ') IF(NOUT.NE.6) THEN !+++MDC+++ !...VMS !/ OPEN(UNIT=NOUT,ACCESS='SEQUENTIAL',STATUS=OSTATUS, & !/ & FILE=FIZCON_DATA%OUTFIL,CARRIAGECONTROL='LIST') !...WIN, DVF, UNX, LWI, ANS, MOD OPEN(UNIT=NOUT,ACCESS='SEQUENTIAL',STATUS=OSTATUS, & & FILE=FIZCON_DATA%OUTFIL) !---MDC--- END IF ! ! OPEN SCRATCH FILES ! OPEN(UNIT=ISCRX,FORM='UNFORMATTED',STATUS='SCRATCH') OPEN(UNIT=ISCRY,FORM='UNFORMATTED',STATUS='SCRATCH') OPEN(UNIT=ISCRXY,FORM='UNFORMATTED',STATUS='SCRATCH') OPEN(UNIT=ISCRU1,FORM='UNFORMATTED',STATUS='SCRATCH') OPEN(UNIT=ISCRU2,FORM='UNFORMATTED',STATUS='SCRATCH') ! ! OUTPUT SELECTED OPTIONS ! IF(IMDC.LT.4) WRITE(IOUT,'(/A)') ' ' CALL DATE(ADATE) IF(NOUT.NE.IOUT) THEN WRITE(NOUT,'(A///2A,30X,2A/)') CHAR(12), & & 'PROGRAM FIZCON VERSION ',VERSION, & & 'Run on ',ADATE END IF WRITE(NOUT,'(2A)') & & 'Input File Specification------------------------', & & TRIM(FIZCON_DATA%INFIL) IF(FIZCON_DATA%MATMIN.EQ.0.AND.FIZCON_DATA%MATMAX.EQ.0) THEN WRITE(NOUT,'(A)') 'Check the Entire File' ELSE WRITE(NOUT,'(A,I4,A,I4)') & & 'Check Materials---------------------------------', & & FIZCON_DATA%MATMIN,' to ',FIZCON_DATA%MATMAX END IF IF(FIZCON_DATA%ISUM.EQ.1) THEN WRITE(NOUT,'(A)') 'Sum Up Tests will be Performed' WRITE(NOUT,'(A,F8.5)') ' Fractional Difference Allowed '// & & 'is ',FIZCON_DATA%EPSILN ELSE WRITE(NOUT,'(A)') 'Sum Up Tests will be Omitted' END IF IF(FIZCON_DATA%ICKT.EQ.0) THEN WRITE(NOUT,'(A)') 'Deviant Point Check will be Performed' WRITE(NOUT,'(A)') & & 'Consecutive Equal Value Check will be Performed' ELSE WRITE(NOUT,'(A)') 'Deviant Point Check will be Omitted' WRITE(NOUT,'(A)') & & 'Consecutive Equal Value Check will be Omitted' END IF ! 100 RETURN END SUBROUTINE BEGIN ! !*********************************************************************** ! SUBROUTINE SELECT_MATS(MATSIN) ! ! SUBROUTINE GET MATERIALS TO BE EXTRACTED FROM INPUT ! IMPLICIT NONE ! CHARACTER(LEN=*) :: MATSIN ! INTEGER(KIND=I4), INTRINSIC :: INDEX, LEN_TRIM ! CHARACTER(LEN=10) :: BUF CHARACTER(LEN=4) :: BUF1,BUF2 INTEGER(KIND=I4) :: IDASH INTEGER(KIND=I4) :: LBUF ! ! GET THE USER INPUT ! WRITE(IOUT,'(A)') ' ' WRITE(IOUT,FMT=TFMT) ' Enter Range of MAT Numbers - ' READ(NIN,'(A)') MATSIN ! ! BLANK RESPONSE IS THE SAME AS SELECTING ALL ! IF(MATSIN.EQ.' ') THEN FIZCON_DATA%MATMIN = 0 FIZCON_DATA%MATMAX = 0 GO TO 100 END IF ! ! ANALYZE THE USER INPUT ! CALL TOKEN(MATSIN,',',1,BUF) IDASH = INDEX(BUF,'-') IF(IDASH.GT.0) THEN LBUF = LEN_TRIM(BUF) IF(IDASH.EQ.1) THEN BUF1 = ' 1' BUF2 = BUF(2:) ELSE IF(IDASH.EQ.LBUF) THEN BUF2 = '9999' BUF1 = BUF(1:LBUF-1) ELSE BUF1 = BUF(1:IDASH-1) BUF2 = BUF(IDASH+1:) END IF ELSE BUF1 = BUF CALL TOKEN(MATSIN,',',2,BUF2) END IF ! ! CONVERT FROM ASCII ! FIZCON_DATA%MATMIN = 1 FIZCON_DATA%MATMAX = 9999 READ(BUF1,'(BN,I4)',ERR=20) FIZCON_DATA%MATMIN 20 READ(BUF2,'(BN,I4)',ERR=25) FIZCON_DATA%MATMAX ! ! SET THE MATERIAL NUMBER LIMITS ! 25 IF(FIZCON_DATA%MATMIN.LE.0) THEN FIZCON_DATA%MATMIN = 1 END IF IF(FIZCON_DATA%MATMAX.LT.FIZCON_DATA%MATMIN) THEN FIZCON_DATA%MATMAX = FIZCON_DATA%MATMIN END IF IF(FIZCON_DATA%MATMIN.EQ.1.AND.FIZCON_DATA%MATMAX.EQ.9999) THEN FIZCON_DATA%MATMIN = 0 FIZCON_DATA%MATMAX = 0 END IF ! 100 RETURN END SUBROUTINE SELECT_MATS ! !*********************************************************************** ! SUBROUTINE SEARCH(IFIND) ! ! ROUTINE TO CHECK TAPE LABEL AND SEARCH FOR STARTING RECORD ! IMPLICIT NONE ! INTEGER(KIND=I4) :: IFIND ! FLAG IF FIRST DESIRED MATERIAL IS FOUND ! CHARACTER(LEN=80) :: IFIELD ! ! INITIALIZE TO NOT FOUND ! IFIND = 0 ! ! READ AND PARSE FIRST CARD TO SEE IF IT IS A LABEL ! READ(JIN,'(A)',END=90) IFIELD READ(IFIELD,'(A,I4,I2,I3,I5)',ERR=20) TLABEL,MAT,MF,MT,NSEQ ! ! A LABELED TAPE? ! IF(MF.NE.0.OR.MT.NE.0) THEN TLABEL = 'TAPE IS NOT LABELED' LABEL = 0 WRITE(NOUT,'(/A/)') 'TAPE BEING PROCESSED IS NOT LABELED' GO TO 60 ELSE LABEL = MAT WRITE(NOUT,'(/2A,I5/3X,2A)') 'TAPE BEING PROCESSED IS ', & & 'NUMBERED',LABEL,'LABEL IS ',TLABEL END IF GO TO 40 ! ! IF READING ERROR ASSUME A PROPER LABEL AND GO ON ! 20 WRITE (NOUT,'(6X,A//)') & & 'FORMAT ERROR IN FIRST RECORD, PROPER LABEL ASSUMED' TLABEL = 'LABEL RECORD IS NOT READABLE' LABEL = 0 ! ! READ NEXT CARD ! 40 READ(JIN,'(A)',END=90) IFIELD READ(IFIELD,'(66X,I4,I2,I3,I5)',ERR=50) MAT,MF,MT,NSEQ ! ! MT=0, FOUND ANOTHER LABEL ! 50 IF(MT.EQ.0.AND.MF.EQ.0) THEN WRITE(NOUT,'(36X,A)') 'TAPE HAS TOO MANY LABELS' LABEL = MAT GO TO 40 END IF ! ! LOOK FOR BEGINNING OF FIRST MATERIAL REQUESTED ! 60 IF(FIZCON_DATA%MATMIN.GT.0) THEN DO WHILE(MAT.LT.FIZCON_DATA%MATMIN) READ(JIN,'(A)',END=90) IFIELD READ(IFIELD,'(66X,I4,I2,I3,I5)',ERR=65) MAT,MF,MT,NSEQ 65 IF(MAT.LT.0) GO TO 70 END DO IF(MAT.GT.FIZCON_DATA%MATMAX) GO TO 70 END IF GO TO 75 ! ! FAILED TO FIND A MATERIAL ! 70 IF(FIZCON_DATA%MATMIN.EQ.FIZCON_DATA%MATMAX) THEN IF(FIZCON_DATA%MATMIN.EQ.0) THEN EMESS = 'INPUT FILE DOES NOT CONTAIN ANY ENDF EVALUATIONS' ELSE WRITE(EMESS,'(A,I5)') & & 'INPUT FILE DOES NOT CONTAIN MATERIAL', & & FIZCON_DATA%MATMIN END IF ELSE WRITE(EMESS,'(A,I5,A,I5)') & & 'INPUT FILE DOES NOT CONTAIN ANY MATERIALS', & & FIZCON_DATA%MATMIN,' TO',FIZCON_DATA%MATMAX END IF WRITE(NOUT,'(/A)') EMESS IF(NOUT.NE.IOUT) THEN IF(IMDC.LT.4) WRITE(IOUT,'(10X,A)') EMESS END IF GO TO 100 ! ! FOUND BEGINNING OF FIRST MATERIAL REQUESTED ! 75 READ(IFIELD,'(2E11.4,4I11)') C1H,C2H,L1H,L2H,N1H,N2H IFIND = 1 NSEQP = NSEQ GO TO 100 ! ! UNEXPECTED END OF FILE ! 90 IERX = 2 ! 100 RETURN END SUBROUTINE SEARCH ! !*********************************************************************** ! SUBROUTINE CHKSEC ! ! CONTROLS CHECK OF A SECTION BASED ON ITS FILE NUMBER (MF) ! IMPLICIT NONE ! SELECT CASE (MF) ! BRANCH BASE ON FILE CASE (1) CALL CKF1 CASE (2) CALL CKF2 CASE (3) CALL CKF3 CASE (4) CALL CKF4 CASE (5) CALL CKF5 CASE (6) CALL CKF6 CASE (7) CALL CKF7 CASE (8) CALL CKF8 CASE (9,10) CALL CKF9 CASE (12,13) CALL CKF12 CASE (14) CALL CKF14 CASE (15) CALL CKF15 CASE (23) CALL CKF23 CASE (26) CALL CKF26 CASE (27) CALL CKF27 CASE (28) CALL CKF28 CASE (32) CALL CKF32 CASE (31,33) CALL CKF33 CASE (34) CALL CKF34 CASE (35) CALL CKF35 CASE (40) CALL CKF40 CASE DEFAULT IERX = 1 WRITE(EMESS,'(A,I3,A)') 'MF= ',MF,' IS NOT PERMITTED' CALL ERROR_MESSAGE(0) END SELECT ! RETURN END SUBROUTINE CHKSEC ! !*********************************************************************** ! SUBROUTINE CKF1 ! ! CHECK FILE 1 DATA ! IMPLICIT NONE ! INTEGER(KIND=I4) :: IENT ! ! TEST THAT SECTION IS IN THE INDEX ! IF(MT.NE.451) CALL TESTD(1000*MF+MT) ! ! BRANCH ON MT NUMBER ! SELECT CASE (MT) ! CASE (451) ! COMMENTS AND DIRECTORY CALL CKS451 ! CASE (452) ! TOTAL NU BAR IENT = 1 CALL CHKNUB(IENT) ! CASE (455) ! DELAYED NUBAR IENT = 2 CALL CHKNUB(IENT) ! CASE (456) ! PROMPT NUBAR IENT = 3 CALL CHKNUB(IENT) ! CASE (458) !ENERGY RELEASE IN FISSION CALL CKS458 ! END SELECT ! 100 RETURN END SUBROUTINE CKF1 ! !*********************************************************************** ! SUBROUTINE CKS451 ! ! CHECK SECTION 451 DATA ! IMPLICIT NONE ! REAL(KIND=R4), INTRINSIC :: AMOD, FLOAT, AINT ! INTEGER(KIND=I4) :: IZT INTEGER(KIND=I4) :: JPART INTEGER(KIND=I4) :: NCD,NID INTEGER(KIND=I4) :: N1,NN,NC,N REAL(KIND=R4) :: ZTRY,ASAV REAL(KIND=R4) :: ZT,ELISM ! ! INITIALIZE ! ZA = C1H AWR = C2H LRP = L1H LFI = L2H NLIB = N1H NMOD = N2H IZT = ZA/1000. ZT = IZT ! ! TEST CHARGE-MASS REASONABILITY ! IF(MAT.LT.100) THEN ZTRY = FLOAT(MAT) + 100. CALL TEST3F(ZA,ZTRY,'ZA') ELSE ASAV = AMOD(ZA,1000.) IF(ASAV.GT.0.) THEN ZTRY = AINT(ASAV/2.) + 1. CALL TEST6(ZT,1.,ZTRY,'Z') END IF END IF ! ! READ THE NEXT CONTROL RECORD AND SET PARAMETERS ! CALL RDCONT ELIS = C1H STA = C2H LIS = L1H LISO = L2H NFOR = N2H IF(LIS.NE.0.AND.ELIS.EQ.0.0) THEN EMESS = 'ELIS SHOULD NOT BE ZERO FOR A METASTABLE STATE' CALL ERROR_MESSAGE(NSEQP) END IF ! ! ENDF-V FORMAT FILE ! IF(NFOR.EQ.0) THEN NFOR = 5 IF((NLIB.GE.2.AND.NLIB.LE.4).OR.NLIB.EQ.35) THEN NVER = 1 ELSE IF(NLIB.EQ.5) THEN NVER = 2 ELSE IF(NLIB.EQ.6) THEN NVER = 3 ELSE NVER = 5 END IF ENMAX = 2.0E+7 NSUB = 10 AWI = 1. ELSE ! ! ENDF-VI OR LATER FORMAT, READ ANOTHER CONTROL RECORD ! CALL RDCONT AWI = C1H ENMAX = C2H NSUB = N1H NVER = N2H NFOR = MAX0(6,NFOR) END IF ! ! IS TARGET EXCITATION ENERGY REASONABLE? ! IF(LIS.EQ.0) THEN ELISM = 0. ELSE IF(NSUB.GE.10) THEN ELISM = ENMAX ELSE ELISM = 3.0E+6 END IF END IF CALL TEST6(ELIS,0.0,ELISM,'ELIS') ! ! CHECK FOR CORRECT AWI VALUE ! JPART = NSUB/10 DO NN=1,NPARTS IF(JPART.EQ.IPARTS(NN)) THEN CALL TEST3F(AWI,AWPART(NN),'AWI') GO TO 10 END IF END DO IF(JPART.EQ.11) THEN EMESS = 'AWI TEST BYPASSED FOR ELECTRONS.' ELSE EMESS = 'AWI TEST BYPASSED FOR PARTICLE MASS GREATER THAN 4.' END IF CALL ERROR_MESSAGE(0) ! ! PROCESS LAST CONTROL RECORD ! 10 CALL RDCONT ! ! READ IN COMMENT RECORDS ! NCD = N1H IF(NFOR.GE.6) THEN NID = 5 ELSE NID = 2 END IF DO NC=1,NCD CALL RDTEXT IF(NC.LE.NID) THEN IF(IMDC.LT.4) WRITE(IOUT,'(1X,A66)') TEXT IF(NOUT.NE.IOUT) WRITE(NOUT,'(5X,A66)') TEXT END IF END DO ! ! SET DECAY OPTIONS AT FIRST MATERIAL ON A DECAY DATA TAPE ! ! IF(NSUB.EQ.4.AND.IDDONE.EQ.0) THEN ! CALL SETDCHK ! IDDONE = 1 ! END IF ! ! PROCESS DIRECTORY ! N1 = 0 NXC = N2H DO N=1,NXC CALL RDCONT IF(L1H.EQ.9.OR.L1H.EQ.10) THEN NISSEC = NISSEC + 1 MTISO(NISSEC) = L2H END IF N1 = N1 + 1 INDX(N1,1) = 1000*L1H + L2H INDX(N1,2) = 1 ENGS(N1,1) = 0. ENGS(N1,2) = 0. END DO ! ! MAKE SURE SECTION IS IN THE INDEX ! CALL TESTD(1000*MF+MT) ! ! INITIALIZE FOR FISSION ENERGY RELEASE TEST ! MT458 = 0 ERQ = 0.0 ! ! INITIALIZE FOR NUBAR SUMUP TEST ! IF(LFI.EQ.1.AND.FIZCON_DATA%ISUM.EQ.1) CALL SUM452(-1) ! RETURN END SUBROUTINE CKS451 ! !*********************************************************************** ! SUBROUTINE CHKNUB(IENT) ! ! CHECK NUBAR SECTIONS ! IMPLICIT NONE ! INTEGER(KIND=I4) :: IENT ! INTEGER(KIND=I4) :: NN,N REAL(KIND=R4) :: E,VNU REAL(KIND=R4) :: ELO,EHI ! INTEGER(KIND=I4), PARAMETER :: NNUS=3 CHARACTER(LEN=4), DIMENSION(NNUS), PARAMETER :: & & KNU = (/'NU ','NUD ','NUP '/) REAL(KIND=R4), DIMENSION(NNUS), PARAMETER :: & & UPR = (/10.0,1.0,10.0/) ! IF(IENT.EQ.2) THEN !********READ DECAY CONSTANTS IF(L1H.EQ.0) THEN CALL RDLIST CALL TEST5Y(1,NPL,1,1) ELSE CALL RDTAB2 DO N=1,NP2 CALL RDLIST END DO END IF !********CHECK IF LAMBDA-S ARE IN INCREASING ORDER END IF ! ! PROCESS NU BAR ! IF(L2H.EQ.1) THEN !*****POLYNOMIAL REPRESENTATION CALL RDLIST VNU = 0.0 E = 1.0 DO NN=1,NPL VNU = VNU + Y(NN)*E E = E*ENMAX END DO CALL TEST6(VNU,0.0,UPR(IENT),KNU(IENT)) ELO = ENMIN EHI = ENMAX ELSE !*****TABULAR REPRESENTATION CALL RDTAB1 CALL TEST6Y(0.0,UPR(IENT),KNU(IENT)) ELO = X(1) EHI = X(NP) END IF ! ! DO SUMUP TEST ! IF(ITEST.EQ.1) CALL SUM452(MT) ! ! STORE ENERGY SPAN OF THE SECTION ! CALL STORF(MF,MT,ELO,EHI) ! ! CHECK ENERGY RANGE OF NU BAR SECTIONS ! IF(MT.EQ.452) THEN CALL TESTER(ELO,EHI,QUNK) ELSE CALL ISFIL(MF,MF,MT,452) END IF ! RETURN END SUBROUTINE CHKNUB ! !*********************************************************************** ! SUBROUTINE CKS458 ! ! CHECK ENERGY RELEASE PER FISSION ! IMPLICIT NONE ! REAL(KIND=R4), INTRINSIC :: ABS ! INTEGER(KIND=I4) :: K REAL(KIND=R4) :: YK REAL(KIND=R4) :: SSUM REAL(KIND=R4) :: ET,DELTA,ERBAR ! MT458 = 1 IF(LFI.NE.1) THEN EMESS = 'SECTION SHOULD BE USED FOR FERTILE AND '// & & 'FISSIONABLE ISOTOPES ONLY' CALL ERROR_MESSAGE(0) END IF CALL RDLIST !*****SUM PARTIAL ENERGIES SSUM = 0.0 DO K=1,NPL-2,2 YK = Y(K) IF(YK.LT.0.0) THEN WRITE(EMESS,'(A,I3)') & & 'NEGATIVE FISSION ENERGY COMPONENT #',K CALL ERROR_MESSAGE(NSEQP) ELSE IF(YK.LT.Y(K+1)) THEN WRITE(EMESS,'(A,I3)') & & 'ERROR GREATER THAN VALUE AT COMPONENT #',K CALL ERROR_MESSAGE(NSEQP) END IF IF(K.LE.13) SSUM = SSUM + YK END DO !*****TEST SUMS ERQ = Y(15) ET = Y(17) DELTA = ABS(ET-SSUM)/ET IF(DELTA.GT.FIZCON_DATA%EPSILN) THEN WRITE(EMESS,'(A,1PE12.5,A,1PE12.5)') & & 'TOTAL ENERGY RELEASE PER FISSION=',ET, & & ' SUM OF PARTIALS=',SSUM CALL ERROR_MESSAGE(0) END IF ERBAR = Y(13) DELTA = ABS(SSUM-ERBAR-ERQ)/ERQ IF(DELTA.GT.FIZCON_DATA%EPSILN) THEN WRITE(EMESS,'(A,1PE12.5,A,1PE12.5,A)') & & 'TOTAL ENERGY (',SSUM,') LESS NEUTRINO ENERGY (', & & ERBAR,')' CALL ERROR_MESSAGE(0) WRITE(EMESS,'(A,1PE12.5,A)') & & ' DOES NOT EQUAL RELEASE (',ERQ,')' CALL ERROR_MESSAGE(0) END IF ! RETURN END SUBROUTINE CKS458 ! !*********************************************************************** ! SUBROUTINE CKF2 ! ! CHECK FILE 2 DATA ! IMPLICIT NONE ! INTEGER(KIND=I4), INTRINSIC :: IFIX REAL(KIND=R4), INTRINSIC :: ABS, AMOD ! INTEGER(KIND=I4) :: NIS INTEGER(KIND=I4) :: INAT,IZI,IZH INTEGER(KIND=I4) :: LRU,LRF,LFW INTEGER(KIND=I4) :: NUMSQ1 INTEGER(KIND=I4) :: NE,NI,NER REAL(KIND=R4) :: ZAH,AWRH,ABNTOT,SPI REAL(KIND=R4) :: AWRIT REAL(KIND=R4) :: ABNM REAL(KIND=R4) :: EL,EH,EUBN1,ELB,EUB REAL(KIND=R4) :: DELTA,DELTAL,DELTAU ! ! TEST THAT SECTION IS IN THE INDEX ! CALL TESTD(1000*MF+MT) ! ! STORE VARIABLES FROM HEAD RECORD ! NIS = N1H ZAH = C1H AWRH = C2H ! ! ONLY ONE ISOTOPE FOR IF NOT A NATURAL ELEMENT ! IF(AMOD(ZAH,1000.).EQ.0.0) THEN INAT = 1 ELSE INAT = 0 CALL TEST3(NIS,1,'NIS') END IF ! ! LOOP ON ALL ISOTOPES ! ABNTOT = 0.0 IZH = IFIX(ZAH)/1000 DO NI=1,NIS CALL RDCONT ABNTOT = ABNTOT + C2H ! ! SET LIMITS ON AWRI ! IZI = IFIX(C1H)/1000 AWRIT = (C1H-1000.*FLOAT(IZI))/FACTOR AWRI1 = AWRIT + 1. AWRI2 = AWRIT - 1. ! ! CHECKS FOR NATURAL ELEMENT ! IF(INAT.EQ.1) THEN ABNM = 0.0 IF(IZI.NE.IZH) THEN EMESS = 'ISOTOPE Z SHOULD EQUAL MATERIAL Z' CALL ERROR_MESSAGE(NSEQP) END IF IF(C2H.EQ.0.0) THEN EMESS = 'ISOTOPE ABUNDANCE CANNOT BE 0.0.' CALL ERROR_MESSAGE(NSEQP) END IF ! ! CHECKS FOR SINGLE ISOTOPE ! ELSE ABNM = 1. IF(C1H.NE.ZA) THEN EMESS = 'ISOTOPE ZA SHOULD EQUAL MATERIAL ZA' CALL ERROR_MESSAGE(NSEQP) END IF END IF ! ! CHECK ABUNDANCE ! CALL TEST6(C2H,ABNM,1.0,'ABN') ! ! INITIALIZE FOR ISOTOPE ! LFW = L2H NER = N1H E1 = BIGNO E2 = 0. ! ! LOOP ON ENERGY RANGES ! DO NE=1,NER CALL RDCONT EL = C1H EH = C2H LRU = L1H LRF = L2H NRO = N1H E1 = AMIN1(E1,EL) E2 = AMAX1(E2,EH) IF(EL.GT.EH) THEN EMESS = 'ENERGY RANGE LIMITS WRONG' CALL ERROR_MESSAGE(NSEQP) END IF ! ! CHECK FOR CONTINUITY OF REGION BOUNDARIES ! IF(NE.NE.1) THEN DELTA = ABS(1.-EL/EUBN1) IF(DELTA.GT.EPSILN5) THEN EMESS = 'RESONANCE ENERGY RANGE NOT CONTINUOUS' CALL ERROR_MESSAGE(NSEQP1) WRITE(EMESS,'(4X,A,I6)') & & 'PREVIOUS RANGE DEFINED AT RECORD',NUMSQ1 CALL ERROR_MESSAGE(0) END IF END IF EUBN1 = EH NUMSQ1 = NSEQP1 ! ! PROCESS EACH DIFFERENT RESONANCE REGION REPRESENTATION ! IF(LRU.EQ.0) THEN CALL RDCONT SPI = C1H CALL TESTSP(SPI) ELSE IF(LRU.EQ.1) THEN IF((LRF.GE.1.AND.LRF.LE.3).OR.LRF.EQ.5) THEN CALL CHKBW(LRF) ELSE IF(LRF.EQ.4) THEN CALL CHKAA ELSE IF(LRF.EQ.6) THEN CALL CHKHR END IF ELSE IF(LRU.EQ.2) THEN CALL CHKUR(LRF,LFW) END IF END DO ! ! CHECK THAT ISOTOPES SPAN SAME ENERGY RANGE ! IF(NI.EQ.1) THEN ELB = E1 EUB = E2 ELSE DELTAL = ABS(1.-E1/ELB) DELTAU = ABS(1.0-E2/EUB) IF(DELTAL.GT.EPSILN5.OR.DELTAU.GT.EPSILN5) THEN WRITE(EMESS,'(A,I2,A,1PE12.5,A,1PE12.5,A)') & & 'ISOTOPE #',NI,' ENERGY RANGE(',E1,' TO ',E2,')' CALL ERROR_MESSAGE(0) WRITE(EMESS,'(4X,A,1PE12.5,A,1PE12.5,A)') & & 'DIFFERS FROM THE FIRST(',ELB,' TO ',EUB,')' CALL ERROR_MESSAGE(0) END IF END IF END DO ! ! TEST THAT ABUNDANCES ADD UP TO ONE ! IF((ABS(ABNTOT-1.)).GT.EPSILN3) THEN EMESS = 'ISOTOPIC ABUNDANCES DO NOT ADD UP TO UNITY' CALL ERROR_MESSAGE(0) END IF ! RETURN END SUBROUTINE CKF2 ! !*********************************************************************** ! SUBROUTINE CHKBW(LRF) ! ! CHECK BREIT-WIGNER, REICH-MOORE, AND R-MATRIX REPRESENTATION ! IMPLICIT NONE ! INTEGER(KIND=I4) :: LRF ! REAL(KIND=R4), INTRINSIC :: ABS ! INTEGER(KIND=I4) :: NREP INTEGER(KIND=I4) :: NLS INTEGER(KIND=I4) :: IGN INTEGER(KIND=I4) :: ISEQ INTEGER(KIND=I4) :: NL,I REAL(KIND=R4) :: AWRIL REAL(KIND=R4) :: FL,AJLO,AJHI,AJ REAL(KIND=R4) :: SPI,GN ! ! READ AND TEST ENERGY DEPENDENT SCATTERING LENGTH ! IF(NRO.NE.0) THEN CALL RDTAB1 END IF ! ! CHECK SPIN AND ENERGY INDEPENDENT SCATTERING LENGTH ! CALL RDCONT NLS = N1H SPI = C1H CALL TESTSP(SPI) ! ! PROCESS PARAMETERS FOR ALL L VALUES ! DO NL=1,NLS CALL RDLIST NREP = NPL/N2L !******* TEST AWRI IF(NL.EQ.1) THEN CALL TEST6(C1L,AWRI2,AWRI1,'AWR') AWRIL = C1L ELSE CALL TEST3F(C1L,AWRIL,'AWR') END IF !********CHECK FOR CORRECT L-VALUE FOR THIS SUBSECTION CALL TEST3(L1L,NL-1,'L') !********GET RANGE OF VALID J-VALUES FL = L1L AJLO = ABS(ABS(SPI-FL)-0.5) AJHI = SPI+FL+0.5 !********TEST THAT RESONANCE ENERGIES ARE IN INCREASING ORDER CALL TEST5Y(1,NPL,NREP,1) !********TEST IF PARTIAL WIDTHS ADD UP TO TOTAL IF(LRF.LT.3) CALL TESTW(1,NPL,NREP) ! ! TEST ON INDIVIDUAL PARAMETERS ! DO I=4,NPL,NREP !***********POSSIBLE J-VALUE? AJ = Y(I-2) IF(AJ.LT.0.0.AND.LRF.EQ.3) THEN AJ = - AJ IF(FL.EQ.0.0.AND.SPI.EQ.0.0) THEN ISEQ = NSEQP1 + (I+2)/NREP EMESS = 'AJ CANNOT BE NEGATIVE FOR L AND SPI '// & & 'EQUAL ZERO ' CALL ERROR_MESSAGE(0) WRITE(EMESS,'(4X,A,1PE12.5)') 'FOR RESONANCE',Y(I-3) CALL ERROR_MESSAGE(ISEQ) END IF END IF CALL TEST6(AJ,AJLO,AJHI,'AJ') !***********TEST FOR ZERO NEUTRON WIDTH IF(LRF.EQ.3) THEN IGN = I - 1 ELSE IGN = I END IF GN = Y(IGN) IF(GN.EQ.0.) THEN ISEQ = NSEQP1 + (I+2)/NREP WRITE(EMESS,'(A,1PE12.5)') & & 'NEUTRON WIDTH IS ZERO FOR RESONANCE',Y(I-3) CALL ERROR_MESSAGE(ISEQ) END IF END DO END DO ! RETURN END SUBROUTINE CHKBW ! !*********************************************************************** ! SUBROUTINE CHKAA ! ! CHECK ADLER-ADLER RESONANCE REPRESENTATION ! IMPLICIT NONE ! INTEGER(KIND=I4) :: NLS,NJS INTEGER(KIND=I4) :: NL,NJ REAL(KIND=R4) :: SPI REAL(KIND=R4) :: AWRI REAL(KIND=R4) :: FL,AJLO,AJHI ! ! READ AND TEST ENERGY DEPENDENT SCATTERING LENGTH ! IF(NRO.NE.0) THEN CALL RDTAB1 END IF ! ! CHECK SPIN AND ENERGY INDEPENDENT SCATTERING LENGTH ! CALL RDCONT NLS = N1H SPI = C1H CALL TESTSP(SPI) ! ! PROCESS PARAMETERS FOR ALL L VALUES ! CALL RDLIST AWRI = C1L CALL TEST6(AWRI,AWRI2,AWRI1,'AWR') ! ! PROCESS ALL L VALUES ! DO NL=1,NLS CALL RDCONT !********CHECK FOR CORRECT L-VALUE FOR THIS SUBSECTION CALL TEST3(L1H,NL-1,'L') !********GET RANGE OF VALID J-VALUES FL = L1H AJLO = ABS(ABS(SPI-FL)-0.5) AJHI = SPI+FL+0.5 ! ! PROCESS ALL J VALUES ! NJS = N1H DO NJ=1,NJS CALL RDLIST !**********POSSIBLE J-VALUE? CALL TEST6(C1L,AJLO,AJHI,'AJ') !***********TEST INCREASING ORDER OF RESONANCE ENERGIES CALL TEST5Y(1,NPL,12,1) END DO END DO ! RETURN END SUBROUTINE CHKAA ! !*********************************************************************** ! SUBROUTINE CHKHR ! ! CHECK HYBRID R-FUNCTION REPRESENTATION ! IMPLICIT NONE ! INTEGER(KIND=I4), INTRINSIC :: INT REAL(KIND=R4), INTRINSIC :: FLOAT, ABS ! INTEGER(KIND=I4) :: NLS,NJS,NSS INTEGER(KIND=I4) :: NL,NJ,NS INTEGER(KIND=I4), DIMENSION(4) :: MTRE INTEGER(KIND=I4) :: NCRE,MTREC INTEGER(KIND=I4) :: NAW,NCR INTEGER(KIND=I4) :: LBK,LPS,NLSJ,NREP INTEGER(KIND=I4) :: ISEQ INTEGER(KIND=I4) :: IGN INTEGER(KIND=I4) :: I,II,III,LIL REAL(KIND=R4) :: SPI REAL(KIND=R4) :: QTLOW,QTHIGH REAL(KIND=R4) :: AWRI,AWRC REAL(KIND=R4) :: FL,FLP,AJLO,AJHI REAL(KIND=R4) :: ETST0,ETST REAL(KIND=R4) :: GN REAL(KIND=R4) :: AC REAL(KIND=R4) :: AS,FAS,AJ,FAJ REAL(KIND=R4) :: AL,ALTEST,EPTEST REAL(KIND=R4), DIMENSION(4) :: APART ! ! READ AND TEST ENERGY DEPENDENT SCATTERING LENGTH ! IF(NRO.NE.0) THEN CALL RDTAB1 END IF ! ! TEST SPIN ! CALL RDCONT NLS = N1H SPI = C1H CALL TESTSP(SPI) ! ! PROCESS EACH REACTION CHANNEL ! CALL RDCONT NCRE = N2H !*****READ REACTION CHANNEL DEFINITIONS CALL RDCONT NAW = 0 MTRE = (/L1H,L2H,N1H,N2H/) DO II=1,4 MTREC = MTRE(II) IF(MTREC.GT.102) THEN NAW = NAW + 1 APART(NAW) = AWPART(MTREC-100) END IF END DO ! ! CHECK THAT Q VALUES ARE REASONABLE FOR THE CORRESPONDING ! REACTION ! CALL RDLIST ETST0 = 0. DO III=1,4 MTREC = MTRE(III) IF(MTREC.EQ.102.OR.MTREC.EQ.18.OR.MTREC.EQ.0) THEN IF(Y(III).NE.0.0) THEN WRITE(EMESS,'(A,I1,A,I1,A,I3,A)') & & 'QRE',III,' FOR MTRE',III,' = ',MTREC, & & ' MUST BE ZERO' CALL ERROR_MESSAGE(NSEQP) END IF ELSE QTLOW = -2.0E+7 QTHIGH = 2.0E+7 ETST = - Y(III) IF(MTREC.GE.51.AND.MTREC.LE.54) THEN IF(ETST.LE.0.0) THEN WRITE(EMESS,'(A,I1,A,I1,A,I3,A)') & & 'QRE',III,' FOR MTRE',III,' = ',MTREC, & & ' MUST BE ','NEGATIVE' CALL ERROR_MESSAGE(NSEQP) END IF IF(ETST0.NE.0.0) THEN IF(ETST.LE.ETST0) THEN EMESS = 'Q-VALUES FOR INELASTIC CHANNELS '// & & 'ARE OUT OF ORDER' CALL ERROR_MESSAGE(NSEQP) END IF END IF ETST0 = ETST QTLOW = 1000. END IF IF(ETST.LT.QTLOW.OR.ETST.GT.QTHIGH) THEN WRITE(EMESS,'(A,I1,A,I1,A,I3,A)') & & 'QRE',III,' FOR MTRE',III,' = ',MTREC, & & ' IS UNREASONABLE' ! CALL ERROR_MESSAGE(NSEQP) END IF END IF END DO !*****READ ANY CHARGED PARTICLE PENETRABILITIES IF(NCRE.GT.0) THEN DO NCR=1,NCRE DO LIL=1,4 CALL RDTAB1 AWRC = C1 CALL TEST3F(AWRC,APART(NCR),'AWRC') END DO END DO END IF ! ! PROCESS EACH L, S, AND J VALUE ! FLP = -1. DO NL=1,NLS CALL RDCONT AWRI = C1H FL = L1H !********CHECK FOR CORRECT L-VALUE FOR THIS SUBSECTION CALL TEST3(L1L,NL-1,'L') !********CHECK ORDER OF LISTS IF(FL.GT.FLP) THEN FLP = FL ELSE EMESS = 'RESONANCE PARAMETER LISTS OUT OF ORDER IN L' CALL ERROR_MESSAGE(NSEQP) END IF CALL TEST6(AWRI,AWRI2,AWRI1,'AWR') NSS = N1H FAS = -1. !********CHANNEL SPIN DO NS=1,NSS CALL RDCONT AS = C1H !********CHECK ORDER OF LISTS IF(AS.GT.FAS) THEN FAS = AS ELSE EMESS = 'RESONANCE PARAMETER LISTS OUT OF ORDER IN S' CALL ERROR_MESSAGE(NSEQP) END IF !***********POSSIBLE S-VALUE? CALL TEST6(AS,SPI-.5,SPI+0.5,'AS') NJS = N1H !***********GET RANGE OF VALID J-VALUES AJLO = ABS(FL-AS) AJHI = FL+AS FAJ = -1. !***********TOTAL SPIN DO NJ=1,NJS CALL RDLIST AJ = C1L !**************CHECK ORDER OF LISTS IF(AJ.GT.FAJ) THEN FAJ = AJ ELSE EMESS = 'RESONANCE PARAMETER LISTS OUT OF ORDER '// & & 'IN L' CALL ERROR_MESSAGE(NSEQP) END IF !**************POSSIBLE J-VALUE? CALL TEST6(AJ,AJLO,AJHI,'AJ') LBK = L1L LPS = L2L NLSJ = N2L NREP = NPL/NLSJ !**************TEST THAT RESONANCE ENERGIES ARE IN INCREASING ORDER CALL TEST5Y(1,NPL,NREP,1) ! ! TEST ON INDIVIDUAL PARAMETERS ! DO I=4,NPL,NREP ISEQ = NSEQP1 + (I+2)/NREP !*****************TEST FOR ZERO NEUTRON WIDTH IGN = I-2 GN = Y(IGN) IF(GN.EQ.0.) THEN WRITE(EMESS,'(A,1PE12.5)') & & 'NEUTRON WIDTH IS ZERO FOR RESONANCE',Y(IGN-1) CALL ERROR_MESSAGE(ISEQ) END IF !*****************TEST THAT OUTGOING ANGULAR MOMENTUM VALUES ARE !*****************INTEGRAL AND REASONABLE DO II=5,8 AL = Y(I+II) IF(AL.LT.0.0.OR.AL.GT.3.0) THEN WRITE(EMESS,'(A,I1,A)') & & 'ALRE',II-2,' IS NOT ACCEPTABLE' CALL ERROR_MESSAGE(ISEQ) END IF ALTEST = FLOAT(INT(AL)) EPTEST = ABS(AL-ALTEST) IF(AL.NE.0.0) EPTEST = EPTEST/AL IF(EPTEST.GT.EPSILN5) THEN WRITE(EMESS,'(A,I1,A)') & & 'ALRE',II-2,' IS NOT AN INTEGRAL NUMBER' CALL ERROR_MESSAGE(ISEQ) END IF END DO END DO !**************READ BACKGROUND IF(LBK.NE.0) THEN CALL RDTAB1 CALL RDTAB1 END IF !**************READ PHASE SHIFTS IF(LPS.NE.0) THEN CALL RDTAB1 CALL RDTAB1 END IF END DO END DO END DO ! RETURN END SUBROUTINE CHKHR ! !*********************************************************************** ! SUBROUTINE CHKUR(LRF,LFW) ! ! CHECK UNRESOLVED REGION ! IMPLICIT NONE ! INTEGER(KIND=I4) :: LRF,LFW ! REAL(KIND=R4), INTRINSIC :: ABS ! INTEGER(KIND=I4) :: MUF INTEGER(KIND=I4) :: NLS,NJS INTEGER(KIND=I4) :: N INTEGER(KIND=I4) :: NL,NJ,MJ REAL(KIND=R4) :: SPI REAL(KIND=R4) :: AWRIL REAL(KIND=R4) :: FL,AJLO,AJHI,AJ ! ! ALL PARAMETERS ENERGY DEPENDENT ! IF(LRF.EQ.2) THEN CALL RDCONT SPI = C1H CALL TESTSP(SPI) ! ! PROCESS ALL L VALUES ! NLS = N1H DO NL=1,NLS CALL RDCONT !***********TEST AWRI IF(NL.EQ.1) THEN CALL TEST6(C1H,AWRI2,AWRI1,'AWR') AWRIL = C1H ELSE CALL TEST3F(C1H,AWRIL,'AWR') END IF !***********CHECK FOR CORRECT L-VALUE FOR THIS SUBSECTION CALL TEST3(L1H,NL-1,'L ') !***********GET RANGE OF VALID J VALUES N = L1H FL = L1H AJLO = ABS(ABS(SPI-FL)-0.5) AJHI = SPI+FL+0.5 ! ! PROCESS ALL J VALUES ! NJS = N1H DO NJ=1,NJS CALL RDLIST !**************POSSIBLE J- VALUE? CALL TEST6(C1L,AJLO,AJHI,'AJ') !**************TEST AMUX, AMUN, AMUG AND AMUF CALL TESTDF(2,N2L) !**************TEST ENERGY GRID CALL TESTE(NPL,6,N,NJ) END DO END DO ELSE ! ! ALL PARAMETERS ENERGY INDEPENDENT ! IF(LFW.EQ.0) THEN CALL RDCONT SPI = C1H CALL TESTSP(SPI) ! ! PROCESS ALL L VALUES ! NLS = N1H DO NL=1,NLS CALL RDLIST !**************TEST AWRI IF(NL.EQ.1) THEN CALL TEST6(C1L,AWRI2,AWRI1,'AWR') AWRIL = C1L ELSE CALL TEST3F(C1L,AWRIL,'AWR') END IF !**************CHECK FOR CORRECT L-VALUE FOR THIS SUBSECTION CALL TEST3(L1L,NL-1,'L') !**************GET RANGE OF VALID J VALUES FL = L1L AJLO = ABS(ABS(SPI-FL)-0.5) AJHI = SPI+FL+0.5 !**************TEST AMUN CALL TESTDF(1,N2L) !**************TEST J VALUES DO MJ=2,NPL,6 AJ = Y(MJ) CALL TEST6(AJ,AJLO,AJHI,'AJ') END DO END DO ELSE ! ! ONLY FISSION WIDTHS ENERGY DEPENDENT ! CALL RDLIST SPI = C1L CALL TESTSP(SPI) ! ! PROCESS ALL J VALUES ! NLS = N2L DO NL=1,NLS CALL RDCONT !**************TEST AWRI IF(NL.EQ.1) THEN CALL TEST6(C1H,AWRI2,AWRI1,'AWR') AWRIL = C1H ELSE CALL TEST3F(C1H,AWRIL,'AWR') END IF !**************CHECK FOR CORRECT L-VALUE FOR THIS SUBSECTION CALL TEST3(L1H,NL-1,'L') !**************GET RANGE OF VALID J VALUES FL = L1H AJLO = ABS(ABS(SPI-FL)-0.5) AJHI = SPI+FL+0.5 ! ! PROCESS ALL J VALUES ! NJS = N1H DO NJ=1,NJS CALL RDLIST !*****************TEST MUF AND AMUN MUF = L2L IF(MUF.LT.1.OR.MUF.GT.4) THEN WRITE(EMESS,'(A,I2,A)') & & 'MUF =',MUF,' NOT IN RANGE 1 TO 4' CALL ERROR_MESSAGE(NSEQP1) END IF CALL TESTDF(1,N2L) !*****************CHECK FOR CORRECT L-VALUE FOR THIS SUBSECTION CALL TEST3(L1L,NL-1,'L') !*****************CHECK J VALUE AJ = Y(2) CALL TEST6(AJ,AJLO,AJHI,'AJ') END DO END DO END IF END IF ! RETURN END SUBROUTINE CHKUR ! !*********************************************************************** ! SUBROUTINE TESTW(NBEG,NVALS,NSTEP) ! ! TEST THAT PARTIAL WIDTHS ADD UP TO TOTAL ! IMPLICIT NONE ! INTEGER(KIND=I4) :: NBEG,NVALS,NSTEP ! REAL(KIND=R4), INTRINSIC :: ABS ! INTEGER(KIND=I4) :: K,KK,K0,K1,K2 INTEGER(KIND=I4) :: KT REAL(KIND=R4) :: TOT,BK,BKK REAL(KIND=R4) :: SSUM,DELTA ! ! INITIALIZE ERROR COUNT ! MESS = 0 ! ! PROCESS EACH SET OF PARAMETERS ! DO K=NBEG,NVALS,NSTEP K0 = K + 2 K1 = K + 3 K2 = K + NSTEP - 1 KK = K TOT = Y(K0) !********ERROR IF TOTAL IS ZERO IF(TOT.LE.0.0) THEN MESS = 0 BKK = Y(KK) WRITE(EMESS,'(A,1PE12.5)') & & 'TOTAL WIDTH LESS THAN OR EQUAL TO ZERO AT ENERGY=',BKK CALL ERROR_MESSAGE(0) GO TO 50 END IF ! ! ADD UP PARTIALS ! SSUM = 0.0 DO KT=K1,K2 SSUM = SSUM + ABS(Y(KT)) END DO ! ! CHECK SUM AGAINST PARTIAL ! DELTA = ABS(1.-SSUM/TOT) IF(DELTA.GT.EPSILN3) THEN IF(MESS.EQ.0) THEN EMESS = 'SUM OF PARTIALS DOES NOT ADD UP TO TOTAL '// & & 'AT THE FOLLOWING POINTS' CALL ERROR_MESSAGE(0) END IF MESS = MESS + 1 BKK = Y(KK) BK = Y(K0) WRITE(EMESS,'(A,1PE12.5,A,1PE12.5,A,1PE12.5)') & & 'ENERGY=',BKK,' GAMMA-TOTAL=',BK,' SUM=',SSUM CALL ERROR_MESSAGE(0) END IF 50 END DO ! RETURN END SUBROUTINE TESTW ! !*********************************************************************** ! SUBROUTINE TESTE(NPLT,L,NL,J) ! ! ROUTINE TO COMPARE UNRESOLVED ENERGY REGION GRIDS ! IMPLICIT NONE ! INTEGER(KIND=I4) :: NPLT,L,NL,J ! REAL(KIND=R4), INTRINSIC :: ABS ! INTEGER(KIND=I4) :: I2,NPLFST INTEGER(KIND=I4) :: I,I1 REAL(KIND=R4) :: ENU,DEV ! ! SAVE GRID ON FIRST PASS ! IF(J.EQ.1) THEN I2 = 0 NPLFST = NPLT DO I=7,NPLT,L I2 = I2 + 1 EURGRID(I2) = Y(I) END DO GO TO 100 END IF ! ! COMPARE WITH STORED DATA ON SUCCEEDING PASSES ! IF(NPLFST.EQ.NPLT) THEN I1 = 1 DO I=1,I2 I1 = I1 + L ENU = Y(I1) DEV = ABS(1.-ENU/EURGRID(I)) IF(DEV.GT.EPSILN5) THEN WRITE(EMESS,'(A,1PE12.5,A,I2,A,I2)') & & 'ENERGY POINT',ENU,' L STATE',NL,' J STATE',J CALL ERROR_MESSAGE(0) WRITE(EMESS,'(4X,A,1PE12.5)') & & 'DIFFERS FROM VALUE FOR FIRST L AND J STATE', & & EURGRID(I) CALL ERROR_MESSAGE(0) END IF END DO ELSE ! ! NUMBER OF POINTS DIFFER ! WRITE(EMESS,'(A,I2,A,I2)') & & 'ENERGY POINTS FOR L STATE',NL,' J STATE',J CALL ERROR_MESSAGE(0) EMESS = ' DOES NOT EQUAL THE NUMBER OF ENERGY POINTS '// & & 'FOR THE FIRST L AND J STATE' CALL ERROR_MESSAGE(0) END IF ! ! TEST THAT ENERGIES ARE IN INCREASING ORDER ! 100 CALL TEST5Y(1,NPLT,6,1) ! RETURN END SUBROUTINE TESTE ! !*********************************************************************** ! SUBROUTINE TESTDF(N,NW) ! ! TEST FOR LEGAL DEGREES OF FREEDOM ! IMPLICIT NONE ! INTEGER(KIND=I4) :: N,NW ! INTEGER(KIND=I4) :: LINENO INTEGER(KIND=I4) :: I,J REAL(KIND=R4) :: AM ! CHARACTER(LEN=4), DIMENSION(4), PARAMETER :: & & A = (/'AMUX','AMUN','AMUG','AMUF'/) REAL(KIND=R4), DIMENSION(2,4) :: OLIMS DATA OLIMS/1.,2.,1.,2.,0.,0.,1.,4./ ! ! SAVE LINE NUMBER ! LINENO = NSEQP1 + 1 ! ! TEST ONLY NEUTRON WIDTH DEGREES OF FREEDOM ! IF(N.NE.2) THEN AM = Y(3) IF(AM.LT.OLIMS(1,2).OR.AM.GT.OLIMS(2,2)) THEN WRITE(EMESS,'(2A,F4.1,A)') & & A(2),' = ',AM,' NOT IN SPECIFIED RANGE' CALL ERROR_MESSAGE(LINENO) END IF GO TO 100 END IF ! ! TEST FOR ALL WIDTHS ! DO I=1,4 !********SEE IF COMPETITIVE OR FISSION WIDTHS ALL ZERO IF(I.LE.1.OR.I.GE.4) THEN DO J=1,NW IF(Y(6*J+2+I).GT.0.0) GO TO 70 END DO GO TO 90 END IF ! ! TEST FOR LEGAL DEGREES OF FREEDOM ! 70 AM = Y(I+2) IF(AM.LT.OLIMS(1,I).OR.AM.GT.OLIMS(2,I)) THEN WRITE(EMESS,'(2A,F4.1,A)') & & A(I),' = ',AM,' NOT IN SPECIFIED RANGE' CALL ERROR_MESSAGE(LINENO) END IF 90 END DO ! 100 RETURN END SUBROUTINE TESTDF ! !*********************************************************************** ! SUBROUTINE TESTSP(SPIN) ! ! ROUTINE TO TEST LIMITS ON SPIN ! ALSO INSURE INTEGRAL OR HALF INTEGRAL ! IMPLICIT NONE ! REAL(KIND=R4) :: SPIN ! REAL(KIND=R4), INTRINSIC :: ABS, FLOAT ! INTEGER(KIND=I4) :: ISPI REAL(KIND=R4) :: DIF ! ! TEST SPIN ! IF(SPIN.LT.0.) THEN !********TEST FOR NEGATIVE SPIN EMESS = 'NEGATIVE SPIN NOT ALLOWED' CALL ERROR_MESSAGE(NSEQP1) ELSE !********TEST SPIN LIMITS CALL TEST6(SPIN,0.0,16.0,'SPI') END IF ! ! TEST SPIN TO SEE IF INTEGRAL OR HALF-INTEGRAL ! ISPI = SPIN DIF = ABS(SPIN-FLOAT(ISPI)) IF(DIF.NE.0.0.AND.DIF.NE.0.5) THEN EMESS = 'SPIN SHOULD BE INTEGRAL OR HALF INTEGRAL' CALL ERROR_MESSAGE(NSEQP1) END IF ! RETURN END SUBROUTINE TESTSP ! !*********************************************************************** ! SUBROUTINE CKF3 ! ! CHECK FILE 3 DATA ! IMPLICIT NONE ! INTEGER(KIND=I4), INTRINSIC :: MOD ! INTEGER(KIND=I4) :: JPART INTEGER(KIND=I4) :: LR INTEGER(KIND=I4) :: MTT,MTL INTEGER(KIND=I4) :: NBEG,NLMOD,NCONT,IPART INTEGER(KIND=I4) :: N,NNN REAL(KIND=R4) :: Q,QM,QT REAL(KIND=R4) :: ELO,EHI ! ! TEST THAT SECTION IS IN THE INDEX ! CALL TESTD(1000*MF+MT) IFL3 = 1 ! ! INITIALIZE FOR SUMUP TEST FIRST TIME ! IF(ITEST.EQ.0.AND.FIZCON_DATA%ISUM.GT.0) CALL SUMF3(-1) ! ! READ DATA TABLE ! CALL RDTAB1 ! ! SET A FLAG IF ALL VALUES OF CHARGED PARTICLE ELASTIC SIGMA ! ARE SET TO 1.0 ! JPART = NSUB/10 IF(MT.EQ.2.AND.JPART.NE.1) THEN DO N=1,NP IF(Y(N).NE.1.0) THEN CPELAS = 0 GO TO 10 END IF END DO CPELAS = 1 END IF ! ! TEST LR ! 10 LR = L2 Q = C2 QM = C1 CALL TESTLR(LR,QM) ! ! DO Q VALUE TESTS ! CALL TESTQ(QM,Q,LR,X(NP)) ! ! CHECK ENERGY SPAN OF SECTION ! ELO = X(1) EHI = X(NP) IF((MT.GE.18.AND.MT.LE.21).OR.MT.EQ.38) THEN QT = QUNK ELSE QT = Q END IF CALL TESTER(ELO,EHI,QT) ! ! SAVE ENERGY SPAN OF SECTION ! CALL STORF(MF,MT,ELO,EHI) ! ! TEST FOR MISSING LEVELS ! IF(MT.GE.50) THEN IF(MT.LE.91) THEN NBEG = 50 NLMOD = 50 NCONT = 41 IPART = 1 END IF IF(NFOR.GE.6) THEN IF(MT.LT.600.OR.MT.GT.849) GO TO 20 NBEG = 600 NLMOD = 50 NCONT = 49 ELSE IF(MT.LT.699.OR.MT.GT.799) GO TO 20 NBEG = 700 NLMOD = 20 NCONT = 18 END IF MTT = MT - NBEG MTL = MOD(MTT,NLMOD) IF(NBEG.NE.50) IPART = (MTT/NLMOD) + 3 IF(MTL.GE.1.AND.MTL.LT.NCONT) THEN JPART = NSUB/10 IF(MTL.NE.1.OR.JPART.NE.IPARTS(IPART)) THEN CALL TESTP(MF,MT-1) END IF END IF END IF ! ! SAVE SECTION IF NEEDED FOR FILE 9 AND 10 TESTS ! 20 IF(NISSEC.NE.0) THEN DO NNN=1,NISSEC IF(MTISO(NNN).EQ.MT) THEN CALL RDWRIT(ISCRU2,2) GO TO 25 END IF END DO END IF ! ! IF SUMUP DESIRED, DO IT ! 25 IF(FIZCON_DATA%ISUM.NE.0) CALL SUMF3(MT) ! RETURN END SUBROUTINE CKF3 ! !*********************************************************************** ! SUBROUTINE TESTLR(LR,S) ! ! SUBROUTINE TESTS FOR A VALID LR FLAG ! IMPLICIT NONE ! INTEGER(KIND=I4) :: LR REAL(KIND=R4) :: S ! ! LR = 0 ALWAYS ALLOWED ! IF(LR.EQ.0) GO TO 100 ! ! LR = 1 VERSION 6 FORMAT ONLY ! IF(LR.EQ.1) THEN IF(NFOR.GE.6) GO TO 100 ELSE ! ! LR GT 1 NEUTRON INCIDENT FILES ONLY ! IF(NSUB/10.NE.1) GO TO 90 ! ! VALID ONLY FOR DISCRETE LEVELS ! IF(MT.GE.600.AND.MT.LE.849) THEN IF(MOD(MT,50).NE.49) GO TO 50 GO TO 90 END IF IF(MT.LT.50.OR.MT.GT.91) GO TO 90 ! ! CHECK FOR VALID LR VALUE ! 50 IF(LR.EQ.16.OR.LR.EQ.17) THEN IF(NFOR.LT.6) GO TO 100 ELSE IF(LR.GE.22.AND.LR.LE.25) THEN GO TO 100 ELSE IF(LR.GE.28.AND.LR.LE.36) THEN GO TO 100 ELSE IF(LR.EQ.39.OR.LR.EQ.40) THEN IF(NFOR.LT.6) CALL TEST3F(S,0.,'S') GO TO 100 END IF END IF ! ! BAD LR FLAG ! 90 WRITE(EMESS,'(A,I3,A)') 'LR=',LR,' INVALID' CALL ERROR_MESSAGE(NSEQP1) ! 100 RETURN END SUBROUTINE TESTLR ! !*********************************************************************** ! SUBROUTINE TESTQ(QM,QI,LR,EHI) ! ! SUBROUTINE TESTS Q-VALUE TO SEE IF REASONABLE ! Q MUST BE ASCENDING FOR MTS 50-90, 600-849 ! IMPLICIT NONE ! INTEGER(KIND=I4) :: LR REAL(KIND=R4) :: QM,QI,EHI ! INTEGER(KIND=I4) :: ILEVC,IEQU,IQTEST REAL(KIND=R4) :: ELEV,QTLOW,Q,EXL REAL(KIND=R4), PARAMETER :: QLOW=-2.0E+07,QHIGH=2.0E+07 REAL(KIND=R4), PARAMETER :: QFLOW=1.7E+08,QFHIGH=2.1E+08 REAL(KIND=R4), PARAMETER :: QLLOW=1.0E+03,QLHIGH=2.0E+07 ! ! SET UP FOR Q TEST ! CALL SETUP_Q(LR,QM,QI,Q,EXL,ILEVC,IEQU,IQTEST) ! ! Q TESTS ! IF(IQTEST.EQ.1) THEN IF(Q.EQ.0.) GO TO 50 ELSE IF(IQTEST.EQ.2) THEN IF(Q.GE.0.) GO TO 50 ELSE IF(IQTEST.EQ.3) THEN IF(Q.EQ.ELIS) GO TO 50 ELSE IF(IQTEST.EQ.4) THEN IF(Q.NE.ELIS) GO TO 50 QTLOW = AMIN1(-EHI,QLOW) IF(Q.GE.QTLOW.AND.Q.LE.QHIGH) GO TO 50 ELSE IF(IQTEST.EQ.5) THEN QTLOW = AMIN1(-EHI,QLOW) IF(Q.GE.QTLOW.AND.Q.LE.QHIGH) GO TO 50 ELSE IF(IQTEST.EQ.6) THEN IF(Q.LE.0.) GO TO 50 ELSE IF(IQTEST.EQ.7) THEN IF(Q.GE.QFLOW.AND.Q.LE.QFHIGH) GO TO 50 END IF WRITE(EMESS,'(A,1PE12.5,A)') & & 'Q=',Q,' IS NOT REASONABLE FOR THIS SECTION' CALL ERROR_MESSAGE(0) ! ! CHECK IMPLIED INTERMEDIATE LEVEL ENERGY ! 50 IF(ILEVC.EQ.0) THEN IF(EXL-ELIS.NE.0.) THEN EMESS = 'IMPLIED INTERMEDIATE LEVEL ENERGY SHOULD BE 0.0' CALL ERROR_MESSAGE(0) GO TO 100 END IF END IF ELEV = EXL + ELIS IF(IEQU.EQ.0.OR.ELEV.NE.ELIS) THEN IF(ELEV.EQ.0..OR.(ELEV.GE.QLLOW.AND.ELEV.LE.QLHIGH)) GO TO 100 END IF IF(ILEVC.EQ.1.OR.LR.EQ.0) THEN WRITE(EMESS,'(A,1PE12.5,A)') & & 'ELEVEL=',ELEV,' IS NOT REASONABLE FOR THIS SECTION' CALL ERROR_MESSAGE(0) END IF ! 100 RETURN END SUBROUTINE TESTQ ! !*********************************************************************** ! SUBROUTINE SETUP_Q(LR,QM,QI,Q,EXL,ILEVC,IEQU,IQTEST) ! ! ROUTINE TO SETUP Q TEST ! IMPLICIT NONE ! INTEGER(KIND=I4) :: LR,ILEVC,IEQU,IQTEST REAL(KIND=R4) :: QM,QI,Q,EXL ! REAL(KIND=R4), INTRINSIC :: ABS ! INTEGER(KIND=I4) :: IPART,JPART INTEGER(KIND=I4) :: NBEG,NLMOD,NCONT,MTL,MTT REAL(KIND=R4) :: DELTA ! INTEGER(KIND=I4), PARAMETER :: NPARS=6 INTEGER(KIND=I4), DIMENSION(NPARS) , PARAMETER :: & & ISAME = (/0,1001,1002,1003,2003,2004/) ! ! SETUP FOR ENDF-5 OR -6 FORMAT ! IF(NFOR.GE.6) THEN Q = QM EXL = QM - QI + ELIS ELSE Q = QI EXL = ELIS END IF ! ! SAVE Q-VALUE FOR EACH MT IN FILE 3 ! NMT3 = NMT3 + 1 MT3(NMT3) = MT QMVAL(NMT3) = Q QVAL(NMT3) = QI ! ! SET UP TO CHECK Q VALUES AND LEVEL ORDER ! IPART = NSUB/10 JPART = -1 ILEVC = 0 IEQU = 0 ! ! MT = 1 - 49 ! IF(MT.LE.49) THEN IF(MT.EQ.1.OR.MT.EQ.2.OR.MT.EQ.5) THEN IQTEST = 1 ELSEIF(MT.EQ.3) THEN IQTEST = 2 ELSE IF(MT.EQ.4) THEN IF(NFOR.GE.6) THEN ILEVC = 1 IF(IPART.EQ.1) THEN IQTEST = 3 ELSE IQTEST = 4 END IF ELSE IQTEST = 5 END IF ELSE IF(MT.GE.6.AND.MT.LE.10) THEN IQTEST = 4 ELSE IF((MT.GE.11.AND.MT.LE.17).OR.MT.EQ.37) THEN IF(IPART.EQ.1) THEN IQTEST = 6 ELSE IQTEST = 4 END IF ELSE IF((MT.GE.18.AND.MT.LE.21).OR.MT.EQ.38) THEN !***********CHECK IF FISSION Q MATCHES ENERGY RELEASE IN MT458 IF(MT458.NE.0) THEN IF(Q.NE.0.0) THEN DELTA = ABS(ERQ-Q)/Q ELSE DELTA = ABS(ERQ) END IF IF(DELTA.GT.EPSILN3) THEN EMESS = 'Q VALUE NOT COMPATIBLE WITH MF=1, MT=458' CALL ERROR_MESSAGE(NSEQP1) WRITE(EMESS,'(4X,A,1PE12.5,A,1PE12.5)') & & 'Q=',Q,' ENERGY RELEASE=',ERQ CALL ERROR_MESSAGE(0) END IF END IF IQTEST = 7 ELSE IQTEST = 4 END IF ! ! MT = 50 - 91, SINGLE OUTGOING NEUTRONS ! ELSE IF(MT.LE.91) THEN NBEG = 50 NLMOD = 50 NCONT = 41 ILEVC = 2 MTL = MT - NBEG JPART = 1 IF(IPART.EQ.JPART) THEN IEQU = 1 ELSE IEQU = 0 END IF CALL CHK_LEVEL(Q,QI,QM,LR,MTL,NCONT,IEQU,QMVAL(NMT3)) IF((LR.EQ.0.OR.LR.EQ.31).OR.(LR.EQ.39.OR.LR.EQ.40)) THEN IF(IEQU.EQ.1) THEN IQTEST = 3 ELSE IQTEST = 4 END IF ELSE IQTEST = 5 END IF ! ! NO MT'S BETWEEN 92 AND 100 ! ELSE IF(MT.LE.100) THEN GO TO 100 ! ! MTS FROM 101 TO 207 ! ELSE IF(MT.LE.207) THEN IF(NFOR.GE.6) ILEVC = 1 !********MT = 101 - 107 IF(MT.EQ.101) THEN IQTEST = 2 ELSE IF(MT.GE.102.AND.MT.LE.107) THEN IF(IPART.EQ.ISAME(MT-101)) THEN IQTEST = 3 ELSE IQTEST = 4 END IF !********MT = 108 - 120 ELSE IF(MT.GE.108.AND.MT.LT.120) THEN IQTEST = 4 ELSE IF(MT.EQ.120) THEN IQTEST = 2 ELSE IF(MT.GE.121.AND.MT.LT.201) THEN GO TO 100 !********MT = 201 - 207 ELSE IF(MT.EQ.201) THEN IF(IPART.EQ.1) THEN IQTEST = 3 ELSE IF(IPART.EQ.ISAME(MT-201)) THEN IQTEST = 3 END IF ELSE IQTEST = 4 END IF ! ! MT > 600, SINGLE OUTGOING CHARGED PARTICLES ! ELSE IF(MT.GE.600.AND.MT.LE.849) THEN IF(NFOR.GE.6) THEN NBEG = 600 NLMOD = 50 NCONT = 49 ILEVC = 1 ELSE IF(MT.LT.700.OR.MT.GT.799) GO TO 100 NBEG = 700 NLMOD = 20 NCONT = 18 ILEVC = 2 END IF MTT = MT - NBEG MTL = MOD(MTT,NLMOD) JPART = ISAME((MTT/NLMOD)+2) IF(IPART.EQ.JPART) THEN IEQU = 1 ELSE IEQU = 0 END IF CALL CHK_LEVEL(Q,QI,QM,LR,MTL,NCONT,IEQU,QMVAL(NMT3)) IF((LR.EQ.0.OR.LR.EQ.31).OR.(LR.EQ.39.OR.LR.EQ.40)) THEN IF(IEQU.EQ.1) THEN IQTEST = 3 ELSE IQTEST = 4 END IF ELSE IQTEST = 5 END IF ELSE GO TO 100 END IF ! 100 RETURN END SUBROUTINE SETUP_Q ! !*********************************************************************** ! SUBROUTINE CHK_LEVEL(Q,QI,QM,LR,MTL,NCONT,IEQU,QMVALT) ! ! CHECK Q VALUE AND LEVEL ORDER FOR SINGLE PARTICLE EMISSION ! CHANNELS ! IMPLICIT NONE ! INTEGER(KIND=I4) :: LR,MTL,NCONT,IEQU REAL(KIND=R4) :: Q,QI,QM,QMVALT ! INTEGER(KIND=I4) :: IFLEV,ISETQM INTEGER(KIND=I4), SAVE :: LRPR REAL(KIND=R4) :: QMSAV,EXL REAL(KIND=R4), SAVE :: EXLP ! ! INITIALIZE ON FIRST MT OF AN OUTGOING PARTICLE TYPE ! IF(MTL.EQ.0) THEN QMSAV = Q IFLEV = 1 ISETQM = 1 ELSE IF(MTL.EQ.1) THEN IF(IEQU.EQ.1) THEN QMSAV = ELIS IFLEV = 1 ISETQM = 1 ELSE IFLEV = 0 ISETQM = 0 END IF LRPR = 0 EXLP = 0.0 ELSE IF(MTL.GT.1) THEN IFLEV = 0 ISETQM = 0 END IF ! ! IN ENDF-6 FORMAT CHECK CONSISTANCY OF QI AND QM ! IF(NFOR.GE.6) THEN EXL = QMSAV - QI + ELIS IF((LR.EQ.0.OR.LR.EQ.31).OR.(LR.EQ.39.OR.LR.EQ.40)) THEN IF(MTL.EQ.0) THEN CALL TEST3F(QI,QM,'QI') ELSE IF(ISETQM.EQ.1) CALL TEST3F(QM,QMSAV,'QM') END IF END IF ELSE QMVALT = QMSAV Q = QMSAV EXL = Q - QI + ELIS END IF ! ! CHECK ORDER OF LEVELS ! IF(MTL.LT.NCONT) THEN IF(IFLEV.EQ.0) THEN IF(EXLP.GT.EXL) THEN GO TO 90 ELSE IF(EXLP.EQ.EXL) THEN !**************LEVEL ENERGIES EQUAL OK ONLY IF LR FLAGS DIFFER IF(MF.NE.3.OR.LRPR.EQ.LR) GO TO 90 END IF END IF !********LEVEL ENERGY ORDER OK EXLP = EXL LRPR = LR END IF GO TO 100 ! ! ERROR MESSAGE ! 90 WRITE(EMESS,'(A,I4)') & & 'SECTIONS ARE NOT IN INCREASING LEVEL ENERGY ORDER AT MT =',MT CALL ERROR_MESSAGE(0) ! 100 RETURN END SUBROUTINE CHK_LEVEL ! !*********************************************************************** ! SUBROUTINE CKF4 ! ! CHECK FILE 4 DATA ! IMPLICIT NONE ! INTEGER(KIND=I4), INTRINSIC :: MOD ! INTEGER(KIND=I4) :: LTT,LVT,LI,LCT INTEGER(KIND=I4) :: NM INTEGER(KIND=I4) :: ICONT,MTT,MTL INTEGER(KIND=I4) :: NBEG,NLMOD,NCONT INTEGER(KIND=I4) :: NE INTEGER(KIND=I4) :: N REAL(KIND=R4) :: ELO,EHI,FNORM REAL(KIND=R4), DIMENSION(2) :: X2 ! ! TEST THAT SECTION IS IN THE INDEX ! CALL TESTD(1000*MF+MT) LTT = L2H ! ! NO TRANSFORMATION MATRIX ! LVT = L1H IF(LVT.EQ.0) THEN CALL RDCONT LI = L1H LCT = L2H ! ! WITH TRANSFORMATION MATRIX ! ELSE CALL RDLIST LI = L1L LCT = L2L NM = N2L IF(NM.GE.2) THEN IF(MOD(NM,2).NE.0) THEN WRITE(EMESS,'(A,I3,A)') 'NM=',NM,' SHOULD BE EVEN' CALL ERROR_MESSAGE(NSEQP1) END IF END IF END IF ! ! DETERMINE IF A CONTINUUM OR DISCRETE CHANNEL REACTION ! IF((MT.GE.50.AND.MT.LT.91).OR.MT.EQ.2) THEN ICONT = 0 ELSE ICONT = 1 END IF IF(NFOR.GE.6) THEN IF(MT.LT.600.OR.MT.GT.849) GO TO 30 NBEG = 600 NLMOD = 50 NCONT = 49 ELSE IF(MT.LT.699.OR.MT.GT.799) GO TO 30 NBEG = 700 NLMOD = 20 NCONT = 18 END IF MTT = MT - NBEG MTL = MOD(MTT,NLMOD) IF(MTL.LT.NCONT) ICONT = 0 ! ! CHECK IF FRAME OF REFERENCE APPROPRIATE TO CHANNEL TYPE ! 30 IF(ICONT.EQ.1.AND.LCT.EQ.2) THEN EMESS = 'CONTINUUM REACTION RECOMMENDS LCT=1' CALL ERROR_MESSAGE(NSEQP1) ELSE IF(ICONT.EQ.0.AND.LCT.EQ.1) THEN EMESS = 'DISCRETE CHANNEL REACTION REQUIRES LCT=2' CALL ERROR_MESSAGE(NSEQP1) END IF ! ! ISOTROPIC SO ONLY MAKE SURE FILE 3 EXISTS ! IF(LI.NE.0) THEN CALL TESTP(3,MT) GO TO 100 END IF ! ! LEGENDRE EXPANSIONS ! X2(1) = -BIGNO IF(LTT.EQ.1.OR.LTT.EQ.3) THEN CALL RDTAB2 NE = NP2 DO N=1,NE CALL RDLIST IF(NPL.GE.2.AND.MOD(NPL,2).NE.0) THEN WRITE(EMESS,'(A,I3,A)') & & 'NL=',NPL,' SHOULD BE EVEN' CALL ERROR_MESSAGE(NSEQP1) END IF NP = NPL CALL TEST6Y (-1.0,1.0,'FL') ! ! SAVE MIN AND MAX INCIDENT ENERGY ! IF(N.EQ.1) THEN ELO = C2L ELSE IF(N.EQ.NE) THEN EHI = C2L END IF ! ! CHECK ENERGIES ARE IN INCREASING ORDER ! X2(2) = C2L CALL TEST5(X2,2,1) X2(1) = X2(2) END DO END IF ! ! TABULAR EXPANSIONS ! IF(LTT.EQ.2.OR.LTT.EQ.3) THEN CALL RDTAB2 NE = NP2 DO N=1,NE CALL RDTAB1 CALL TEST6X (-1.0,1.0,'MU') CALL TEST7(FNORM,1) ! ! SAVE MIN AND MAX INCIDENT ENERGY ! IF(LTT.EQ.2.AND.N.EQ.1) ELO = C2 IF(N.EQ.NE) EHI = C2 ! ! CHECK ENERGIES ARE IN INCREASING ORDER ! IF(LTT.EQ.3.AND.N.EQ.1) THEN CALL TEST3F(C2,EHI,'E1') ELSE X2(2) = C2 CALL TEST5(X2,2,1) X2(1) = X2(2) END IF END DO END IF ! ! SAVE ENERGY SPAN OF SECTION ! CALL STORF(MF,MT,ELO,EHI) ! ! CHECK THAT RANGE SPANNED IS THE SAME AS FILE 3 ! CALL ISFIL(MF,3,MT,MT) ! 100 RETURN END SUBROUTINE CKF4 ! !*********************************************************************** ! SUBROUTINE CKF5 ! ! CHECK FILE 5 DATA ! IMPLICIT NONE ! INTEGER(KIND=I4), INTRINSIC :: MOD ! INTEGER(KIND=I4) :: IFISFL,IFMT INTEGER(KIND=I4) :: LF INTEGER(KIND=I4) :: NK,NE INTEGER(KIND=I4) :: NSEQH INTEGER(KIND=I4) :: N,NM REAL(KIND=R4) :: ELO,ELOS,EHI,EHIS,U REAL(KIND=R4) :: FNORM,EONE,ENE REAL(KIND=R4), DIMENSION(2) :: X2 ! ! TEST THAT SECTION IS IN THE INDEX ! CALL TESTD(1000*MF+MT) ! ! INITIALIZE ! IF((MT.GE.18.AND.MT.LE.21).OR.(MT.EQ.38)) THEN IFISFL = 1 ELSE IFISFL = 0 END IF IF((MT.GE.18.AND.MT.LE.21).OR.(MT.EQ.38.OR.MT.EQ.455)) THEN IFMT = 1 ELSE IFMT = 0 END IF IF (NCKF5.EQ.0) THEN IMTFIS = 0 IKTFIS = 0 ILTFIS = 0 NCKF5 = 1 END IF ELO = BIGNO EHI = 0.0 ! ! STORE # SUBSECTIONS FOR TOTAL AND PARTIAL FISSION CROSS SECTIONS ! NK = N1H IF(NLIB.EQ.2) THEN IF(MT.EQ.18) THEN IMTFIS = 1 IKTFIS = NK ELSE IF((MT.GE.19.AND.MT.LE.21).OR.(MT.EQ.38)) THEN IF (NK.NE.IKTFIS) THEN WRITE(EMESS,'(A,I4,A,I4)') & & 'The number of subsections in MT',MT,' equals',NK CALL ERROR_MESSAGE(0) WRITE(EMESS,'(4X,A,I4,2A)') & & 'MUST be ',IKTFIS,', the number of subsections for',& & ' total fission cross section.' CALL ERROR_MESSAGE(0) END IF END IF END IF ! ! PROCESS EACH PARTIAL SECONDARY DISTRIBUTION ! DO N=1,NK CALL RDTAB1 U = C1 IF(-U.GE.2.0E+07.AND.-U.LE.3.0E+07) IFISFL = 1 NSEQH = NSEQP + 1 ELOS = X(1) IF(ELO.GT.ELOS) ELO = ELOS EHIS = X(NP) IF(EHI.LT.EHIS) EHI = EHIS CALL TEST6Y (0.0,1.0,'PKE') ! ! CHECK BASED ON REPRESENTATION ! LF = L2 ! ! STORE LAWS FOR TOTAL FISSION CROSS SECTION AND COMPARE ! LAWS OF PARTIAL FISSION CROSS SECTIONS WITH THE ONES ! FOR THE TOTAL FISSION CROSS SECTION ! IF(NLIB.EQ.2) THEN IF(MT.EQ.18) THEN ILTFIS(N) = LF ELSE IF((MT.GE.19.AND.MT.LE.21).OR.(MT.EQ.38)) THEN IF(ILTFIS(N).EQ.0) THEN WRITE(EMESS,'(A,I2,2A,I3,A)') & & 'Cannot check consistency of law ',LF,' for ', & & 'subsection ',N,' with MT = 18' CALL ERROR_MESSAGE(0) EMESS = ' since MT=18 does not have a '// & & 'corresponding subsection' CALL ERROR_MESSAGE(0) ELSE IF(LF.NE.ILTFIS(N)) THEN WRITE(EMESS,'(A,I2,A,I3,A,I3)') & & 'Law ',LF,' for subsection ',N,' NOT equal to law',& & ILTFIS(N) CALL ERROR_MESSAGE(0) EMESS = ' for corresponding subsection in total'//& & ' fission cross section' CALL ERROR_MESSAGE(0) END IF END IF END IF ! ! LF=1 ! IF(LF.EQ.1) THEN CALL RDTAB2 NE = NP2 X2(1) = -BIGNO DO NM=1,NE CALL RDTAB1 CALL TEST7(FNORM,1) IF(NM.EQ.1) THEN EONE = C2 ELSE IF(NM.EQ.NE) THEN ENE = C2 END IF !**************TEST FOR INCREASING ENERGY ORDER X2(2) = C2 CALL TEST5(X2,2,1) X2(1) = X2(2) !**************TEST UPPER LIMIT OF EMITTED PARTICLE U = C2 CALL UTEST(U,1,NP,IFMT) END DO ! ! LF=5 ! ELSE IF(LF.EQ.5) THEN CALL UTEST(U,LF,NP,IFMT) CALL RDTAB1 EONE = X(1) ENE = X(NP) IF(MT.EQ.455) THEN CALL TEST6Y(1.0,1.0,'THT') ELSE CALL TEST6Y(1.0E+4,1.0E+7,'THT') END IF CALL RDTAB1 CALL TEST7(FNORM,1) ! ! LF=7 ! ELSE IF(LF.EQ.7) THEN CALL UTEST(U,LF,NP,IFMT) CALL RDTAB1 EONE = X(1) ENE = X(NP) CALL TEST6Y(2.0E+5,5.0E+6,'THT') ! ! LF=9 ! ELSE IF(LF.EQ.9) THEN CALL UTEST(U,LF,NP,IFMT) CALL RDTAB1 EONE = X(1) ENE = X(NP) CALL TEST6Y(1.0E+4,1.0E+7,'THT') ! ! LF=11 ! ELSE IF(LF.EQ.11) THEN CALL UTEST(U,LF,NP,IFMT) IFISFL = 1 CALL RDTAB1 EONE = X(1) ENE = X(NP) CALL RDTAB1 ! ! LF=12 ! ELSE IF(LF.EQ.12) THEN CALL UTEST(U,LF,NP,IFMT) IFISFL = 1 CALL RDTAB1 EONE = X(1) ENE = X(NP) ELSE GO TO 100 END IF ! ! CHECK LAW DATA COVERS SAME RANGE AS PROBABILITY ! IF(EONE.NE.ELOS.OR.ENE.NE.EHIS) THEN EMESS = 'PARAMETER TABLE ENERGY RANGE INCORRECT' CALL ERROR_MESSAGE(NSEQH) END IF END DO ! ! SEE THAT A FISSION REACTION HAS A FISSION SPECTRUM ! IF(IFMT.EQ.1.AND.IFISFL.EQ.0) THEN EMESS = 'NO FISSION SPECTRUM FOR A FISSION REACTION' CALL ERROR_MESSAGE(0) END IF ! ! SAVE ENERGY RANGE SPANNED ! CALL STORF(MF,MT,ELO,EHI) ! ! FOR ALL BUT 455, ENERGY RANGE SPANNED MUST BE SAME AS FILE 3 ! IF(MT.NE.455) CALL ISFIL(MF,3,MT,MT) ! ! FOR MT=455, CHECK ONLY THAT SAME SECTION EXISTS IN FILE 1 ! IF(MT.EQ.455) CALL TESTP(1,MT) ! 100 RETURN END SUBROUTINE CKF5 ! !*********************************************************************** ! SUBROUTINE UTEST(U,LF,NPT,IFMT) ! ! ROUTINE TO TEST UPPER LIMIT OF SECONDARY NEUTRON ENERGY ! IMPLICIT NONE ! INTEGER LF,NPT,IFMT REAL(KIND=R4) :: U ! INTEGER(KIND=I4) :: NPART INTEGER(KIND=I4) :: INMT,NN INTEGER(KIND=I4) :: I REAL(KIND=R4) Q,Q1,QNEG,ESMAX,EAVAIL,ETHRS ! INTEGER(KIND=I4), PARAMETER :: NSPARTS=7 INTEGER(KIND=I4), DIMENSION(2,NSPARTS) :: IPART DATA IPART/0,102,1,4,1001,103,1002,104,1003,105,2003,106,2004,107/ ! ! GET Q FROM FILE 3 ! DO I=1,NMT3 IF(MT.EQ.MT3(I)) THEN Q = QVAL(I) GO TO 20 END IF END DO GO TO 100 ! ! LF = 1 ! 20 IF(LF.EQ.1) THEN IF(IFMT.EQ.0.AND.MT.NE.91) THEN ESMAX = X(NPT) EAVAIL = U + Q IF(EAVAIL.LT.ESMAX) THEN WRITE(EMESS,'(A,1PE12.5,A,1PE12.5)') & & 'FOR LF=1 EPMAX FOUND TO BE',ESMAX,' SHOULD BE',EAVAIL CALL ERROR_MESSAGE(0) END IF END IF GO TO 100 ELSE ! ! LF NE 1 ! IF(IFMT.EQ.1) GO TO 100 ETHRS = X(1) IF(Q.GE.0.0) ETHRS = Q Q1 = -Q IF(MT.NE.91) THEN IF(AWR.LT.40.0) THEN IF(ABS(ABS(U-Q1)/Q1).GT.EPSILN3) THEN WRITE(EMESS,'(A,I2,A,1PE12.5,A,1PE12.5)') & & 'FOR LF=',LF,' U OF',U,' OUT OF RANGE FOR Q OF ',Q CALL ERROR_MESSAGE(0) END IF ELSE IF(U.LT.Q1.OR.U.GT.ETHRS) THEN WRITE(EMESS,'(A,I2,A,1PE12.5,A,1PE12.5)') & & 'FOR LF=',LF,' U OF',U,' OUT OF RANGE FOR Q OF',Q CALL ERROR_MESSAGE(0) END IF END IF GO TO 100 ELSE ! ! INELASTIC CONTINUUM ! NPART = NSUB/10 DO I=1,NSPARTS IF(NPART.EQ.IPART(1,I)) GO TO 60 END DO GO TO 100 60 INMT = IPART(2,I) NN = MIN0(INMT,NMT3) DO I=1,NN IF(MT3(I).EQ.INMT) GO TO 70 END DO GO TO 100 70 QNEG = -QVAL(I) IF(U.LT.QNEG) THEN WRITE(EMESS,'(A,I2,A,1PE12.5,A,1PE12.5)') & & 'FOR LF=',LF,' U FOUND TO BE',U,' SHOULD BE .GT.',Q CALL ERROR_MESSAGE(0) END IF END IF END IF ! 100 RETURN END SUBROUTINE UTEST ! !*********************************************************************** ! SUBROUTINE CKF6 ! ! CHECK FILE 6 DATA ! IMPLICIT NONE ! INTEGER(KIND=I4), INTRINSIC :: MOD, FLOAT REAL(KIND=R4), INTRINSIC :: ABS ! INTEGER(KIND=I4) :: NK,LCT,LF INTEGER(KIND=I4) :: NE,INTS INTEGER(KIND=I4) :: ND,NEP,NW,NREPT,NDISC,IUPD INTEGER(KIND=I4) :: L,LTP,NMU,MM,II,NL INTEGER(KIND=I4) :: NSEQH,NSEQC,ICHKER INTEGER(KIND=I4) :: I,J,N,NM REAL(KIND=R4) :: ELO,ELOS,EHI,EHIS,EONE,ENE,EIN REAL(KIND=R4) :: ZAP,ZAPT REAL(KIND=R4) :: E,XL,XU,YL,YU,ANS,ANS1,ANSP,XYINT,XYINTI REAL(KIND=R4), DIMENSION(2) :: X2,X3 REAL(KIND=R4), DIMENSION(201) :: XX,YY ! REAL(KIND=R4), PARAMETER :: PERR=5.0*EPSILN4 ! ! INITIALIZE ! ELO = BIGNO EHI = 0.0 IF (NCKF6.EQ.0) THEN IMTNP = 0 IKTNP = 0 IMTNA = 0 IKTNA = 0 ILTNP = 0 ILTNA = 0 NCKF6 = 1 END IF ! ! TEST THAT SECTION IS IN THE INDEX ! CALL TESTD(1000*MF+MT) ! ! CHECK FOR PRESENCE OF TOTAL (N,P) AND (N,A) CROSS SECTION ! IF(MT.EQ.103) THEN IMTNP = 1 IKTNP = NK ELSE IF(MT.EQ.107) THEN IMTNA = 1 IKTNA = NK END IF ! ! STORE # SUBSECTIONS FOR TOTAL AND PARTIAL (N,P) AND (N,A) ! CROSS SECTIONS ! IF(NLIB.EQ.2) THEN IF(MT.GE.600.AND.MT.LE.649) THEN IF(IMTNP.EQ.1) THEN IF (NK.NE.IKTNP) THEN WRITE(EMESS,'(A,I4,A,I3)') & & 'The number of subsections in MT ',MT,' equals ',NK CALL ERROR_MESSAGE(0) WRITE(EMESS,'(4X,A,I3)') & & 'NOT equal to # subsections for total (n,p) '// & & 'cross section: ',IKTNP CALL ERROR_MESSAGE(0) END IF ELSE EMESS = 'NO distribution given for total (n,p) cross '// & & 'section distribution ' CALL ERROR_MESSAGE(0) WRITE(EMESS,'(4X,A,I3,A,I3)') & & 'with ',NK,' subsections given for MT ',MT CALL ERROR_MESSAGE(0) END IF ELSE IF(MT.GE.800.AND.MT.LE.849) THEN IF (IMTNA.EQ.1) THEN IF (NK.NE.IKTNA) THEN WRITE(EMESS,'(A,I3,A,I3)') & & 'The number of subsections in MT ',MT,' equals ',NK CALL ERROR_MESSAGE(0) WRITE(EMESS,'(4X,A,I3)') & & 'NOT equal to # subsections for total'// & & ' (n,alpha) cross section: ',IKTNA CALL ERROR_MESSAGE(0) END IF ELSE EMESS = 'NO distribution given for total (n,alpha)'// & & ' cross section distribution ' CALL ERROR_MESSAGE(0) WRITE(EMESS,'(4X,A,I3,A,I3)') & & 'with ',NK,' subsections given for MT ',MT CALL ERROR_MESSAGE(0) END IF END IF END IF ! ! LOOP OVER SUBSECTIONS ! NK = N1H LCT = L2H DO N=1,NK CALL RDTAB1 NSEQH = NSEQP + 1 ZAP = C1 IF(MT.EQ.2) THEN ZAPT = FLOAT(NSUB/10) IF (ZAP.NE.ZA.AND.ZAP.NE.ZAPT) THEN CALL TEST3F(ZAP,ZAPT,'ZAP') END IF END IF ELOS = X(1) IF(ELO.GT.ELOS) ELO = ELOS EHIS = X(NP) IF(EHI.LT.EHIS) EHI = EHIS ! ! STORE LAWS FOR TOTAL (N,P) AND (N,ALPHA) CROSS SECTIONS ! AND COMPARE LAWS OF PARTIAL CROSS SECTIONS WITH THE ONES ! FOR THE TOTAL CROSS SECTIONS ! LF = L2 IF(NLIB.EQ.2) THEN IF(MT.EQ.103) THEN ILTNP(N) = LF ELSE IF(MT.EQ.107) THEN ILTNA(N) = LF END IF IF(MT.GE.600.AND.MT.LE.649) THEN IF ((IMTNP.EQ.1).AND.(LF.NE.ILTNP(N))) THEN WRITE(EMESS,'(A,I2,A,I3,A,I3)') & & 'Law ',LF,' for subsection ',N,' for MT ',MT CALL ERROR_MESSAGE(0) WRITE(EMESS,'(4X,A,I2,A)') & & 'NOT equal to law ',ILTNP(N),' for corresponding ' & & //'subsection in total (n,p) cross section' CALL ERROR_MESSAGE(0) END IF ELSE IF(MT.GE.800.AND.MT.LE.849) THEN IF ((IMTNA.EQ.1).AND.(LF.NE.ILTNA(N))) THEN WRITE(EMESS,'(A,I2,A,I3,A,I3)') & & 'Law ',LF,' for subsection ',N,' for MT ',MT CALL ERROR_MESSAGE(0) WRITE(EMESS,'(4X,A,I2,A)') & & 'NOT equal to law ',ILTNA(N),' for corresponding ' & & //'subsection in total (n,alpha) cross section' END IF END IF END IF ! ! TABULAR LAW ! IF(LF.EQ.1) THEN CALL RDTAB2 NE = NP2 INTS = L22 X2(1) = -BIGNO DO I=1,NE CALL RDLIST E = C2L IF(I.EQ.1) THEN EONE = E ELSE IF(I.EQ.NE) THEN ENE = E END IF !**************TEST FOR INCREASING ENERGY ORDER X2(2) = E CALL TEST5(X2,2,1) X2(1) = X2(2) !**************TEST THAT E-PRIME IS IN INCREASING ORDER ND = L1L NEP = N2L NW = NPL NREPT = NW/NEP NDISC = ND*NREPT IF(ND.NE.0) THEN IF(ZAP.EQ.0.) THEN IUPD = 0 ELSE IUPD = 1 END IF CALL TEST5Y(1,NDISC,NREPT,IUPD) END IF IF(ND.NE.NEP) THEN CALL TEST5Y(NDISC+1,NW,NREPT,1) END IF !**************TEST NORMALIZATION INTEGRAL ANS = 0.0 IF(ND.NE.0) THEN DO J=1,ND L = NREPT*(J-1) + 2 ANS = ANS + Y(L) END DO END IF IF(ND+2.LE.NEP) THEN DO J=ND+2,NEP L = NREPT*(J-2) + 1 XL = Y(L) XU = Y(L+NREPT) YL = Y(L+1) YU = Y(L+NREPT+1) CALL ECSI(XL,YL,XU,YU,XL,XU,INTS,ANS1) ANS = ANS + ANS1 END DO END IF IF(ABS(ANS-1.0).GT.PERR) THEN WRITE(EMESS,'(A,F11.6,A,1PE11.4)') & & 'CHECK NORMALIZATION=',ANS,' AT E=',E CALL ERROR_MESSAGE(NSEQP1) END IF END DO ICHKER = 1 ! ! DISCRETE 2-BODY LAW ! ELSE IF(LF.EQ.2) THEN IF((MT.GE.50.AND.MT.LE.90).OR.MT.EQ.2) GO TO 40 IF(MT.GE.600.AND.MT.LE.849) THEN IF(MOD(MT,50).NE.49) GO TO 40 END IF WRITE(EMESS,'(A,I4)') & & 'DISCRETE 2-BODY LAW NOT PERMITTED FOR MT=',MT CALL ERROR_MESSAGE(NSEQP1) 40 IF(LCT.NE.2) THEN WRITE(EMESS,'(A,I1)') & & 'ONLY LCT=2 ALLOWED FOR LAW ',LF CALL ERROR_MESSAGE(NSEQH) END IF CALL RDTAB2 NE = NP2 X2(1) = -BIGNO DO I=1,NE CALL RDLIST E = C2L IF(I.EQ.1) THEN EONE = E ELSE IF(I.EQ.NE) THEN ENE = E END IF !**************TEST FOR INCREASING ENERGY ORDER X2(2) = C2L CALL TEST5(X2,2,1) X2(1) = X2(2) END DO ICHKER = 1 ! ! ISOTROPIC DISCRETE EMISSION ! ELSE IF(LF.EQ.3) THEN IF(LCT.NE.2) THEN WRITE(EMESS,'(A,I1)') & & 'ONLY LCT=2 ALLOWED FOR LAW ',LF CALL ERROR_MESSAGE(NSEQH) END IF ICHKER = 0 ! ! COULOMB ELASTIC LAW ! ELSE IF(LF.EQ.5) THEN IF(NSUB/10.EQ.1) THEN EMESS ='COULOMB LAW NOT ALLOWED FOR INCIDENT NEUTRONS' CALL ERROR_MESSAGE(NSEQP) END IF IF(MT.NE.2) THEN EMESS = 'COULOMB LAW ONLY ALLOWED FOR MT=2' CALL ERROR_MESSAGE(NSEQP) END IF CALL RDTAB2 NE = NP2 X2(1) = -BIGNO DO I=1,NE CALL RDLIST LTP = L1L IF(LTP.LE.10.AND.CPELAS.NE.1) THEN WRITE(EMESS,'(A,I2,A)') & & 'LTP = ',LTP,' REQUIRES THAT ALL ELASTIC CROSS '// & & 'SECTIONS IN FILE 3 BE SET TO 1.0' CALL ERROR_MESSAGE(0) END IF E = C2L IF(I.EQ.1) THEN EONE = E ELSE IF(I.EQ.NE) THEN ENE = E END IF !**************TEST FOR INCREASING ENERGY ORDER X2(2) = C2L CALL TEST5(X2,2,1) X2(1) = X2(2) !**************TEST NORMALIZATION INTEGRAL IF(LTP.GT.10) THEN ANS = 0.0 NL = N2L INTS = LTP - 10 DO J=2,NL L = 2*(J-1) - 1 XL = Y(L) XU = Y(L+2) YL = Y(L+1) YU = Y(L+3) CALL ECSI(XL,YL,XU,YU,XL,XU,INTS,ANS1) ANS = ANS + ANS1 END DO IF(ABS(ANS-1.0).GT.PERR) THEN WRITE(EMESS,'(A,F11.6,A,1PE11.4)') & & 'CHECK NORMALIZATION=',ANS,' AT E=',E CALL ERROR_MESSAGE(NSEQP1) END IF END IF END DO ICHKER = 1 ! ! N-BODY PHASE SPACE ! ELSE IF(LF.EQ.6) THEN CALL RDCONT ICHKER = 0 ! ! ANGLE-ENERGY TABULAR LAW ! ELSE IF(LF.EQ.7) THEN IF(LCT