PROGRAM LISTEF ! ! ********************************************************************** ! * ! * PROGRAM LISTEF ! * ! * PROGRAM TO PRODUCE INTERPRETED LISTINGS OF INFORMATION FROM AN ! * ENDF-V OR -VI FORMAT EVALUATED DATA FILE ! * ! * VERSION 6.0 JULY 1985 C.L. DUNFORD ! * 1. LSTFCV CONVERTED TO FORTRAN-77 ! * 2. NEW ENDF-6 FORMATS FILES 1-27 ADDED ! * 3. FILE 33 LB=6 FORMAT ADDED ! * 4. ADLER-ADLER PROCESSING ADDED ! * 5. SUMRIZ PROGRAM MERGED ! * VERSION 6.1 DECEMBER 1985 C.L. DUNFORD ! * 1. CORRECTIONS TO VERSION 6.0 ! * VERSION 6.2 DECEMBER 1986 C.L. DUNFORD ! * 1. CORRECTIONS TO VERSION 6.1 ! * 2. FILE 6, LAW=7 ADDDED ! * 3. READ MT=457 SPECTRA COVARIANCES ! * VERSION 6.3 AUGUST 1987 C.L. DUNFORD ! * 1. CORRECTIONS TO VERSION 6.2 ! * 2. RESTORE REICH-MOORE TO ENDF-5 FORMAT ! * 3. PROCESS MORE THAN ONE INPUT FILE ! * 4. IMPROVE TITLING ! * 5. FORMAT CHANGES OF MAY 1987 EXCEPT ! * GENERALIZED R-MATRIX ! * VERSION 6.4 MAY 1988 C.L. DUNFORD ! * 1. CORRECTIONS TO VERSION 6.3 ! * 2. HYBRID R-FUNCTION FOR RESONANCE REGION ! * VERSION 6.5 APRIL 1989 C.L. DUNFORD ! * 1. NEW FORMATS FOR FILES 32, 34, 35, AND 40 ! * VERSION 6.6 JUNE 1990 C.L. DUNFORD ! * 1. CORRECTIONS TO VERSION 6.5 ! * 2. PHOTON INTERACTION FORMAT EXTENSIONS ! * 3. LOG STORAGE OF S(ALPHA,BETA) ! * VERSION 6.7 JUNE 1991 C.L. DUNFORD ! * 1. CORRECTIONS TO VERSION 6.6 ! * 2. ADDITION OF PION PRODUCTION MTS ! * VERSION 6.8 JULY 1992 C.L. DUNFORD ! * 1. CORRECTIONS TO VERSION 6.7 ! * 2. VMS INPUT ON COMMAND LINE ! * VERSION 6.9 NOVEMBER 1993 C.L. DUNFORD ! * 1. CORRECTED BROND NLIB NUMBER TO BE 41 ! * VERSION 6.10 NOVEMBER 1995 C.L.DUNFORD ! * 1. ADDED RECOGNITION OF MAT NO. FOR S-METHANE ! * 2. ADDED RECOGNITION OF NEW MT'S, 11, 44, 45 ! * AND 117 ! * 3. CORRECTED OUTPUT FOR THE KALBACH-MANN ! * REPRESENTATION IN FILE 6. ! * 4. CORRECTED DIROUT BY ADDING SAVE STATEMENT ! * TO ASSURE ANSI COMPATIBILITY ! * VERSION 6.11 APRIL 1998 C.L.DUNFORD ! * 1. ALLOW 50000 POINTS IN TAB AND LIST RECORDS ! * 2. ALLOW UP TO 64 LEGENDRE COEFFICIENTS ! * 3. ADD NEW 451 FIELDS NREL AND EMAX ! * 4. NEW LTT=3 REPRESENTATION IN FILE 4 ! * 5 UPDATED ELEMENT NAMES AND SYMBOLS ! * VERSION 6.12 FEBRUARY 2001 C.L.DUNFORD ! * 1. MOVE NREL TO L1 FIELD FROM L2 FIELD ! * 2. IMPLEMENT "$" OUTPUT CONTROL ON UNIX ! * 3. CREATE THREE INTERACTIVE VERSIONS AND ONE ! * BATCH VERSION ! * 4. IMPLEMENT ADDITIONAL AVERAGE ENERGIES IN 457 ! * 5. IMPLEMENT NEW ELECTRO-ATOMIC DATA FORMATS ! * VERSION 6.13 MAY 2002 C.L.DUNFORD ! * 1. 6.12 BUGS REPORTED BY MAY 2002 ! * 2. FORMAT MODIFICATIONS FOR RADIOACTIVE PRODUCTS ! * IN FILES 8, 9 AMD 10 ! * 3. SIMPLE CONVERSION TO F95 STANDARD ! * ! * 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 ! VMS - INTERACTIVE VERSION FOR VMS OPERATING SYSTEM ! WIN - INTERACTIVE VERSION FOR PC USING DIGITAL VISUAL FORTRAN ! UNX - INTERACTIVE VERSION FOR UNIX ! ANS - ANSI STANDARD BATCH MODE VERSION ! ! !*********************************************************************** ! ! INFIL = INPUT FILE SPECIFICATIONS ! SOUFIL = SUMMARY FILE SPECIFICATIONS ! OUFIL = OUTPUT LISTING FILE SPECIFICATIONS ! EDITIT = Y FOR ONE SECTION PER PAGE ! N COMPRESS OUTPUT TO MIMIMUM NUMBER OF PAGES ! IOPT = N PROCESS PARTAL TAPE ! = Y PROCESS FULL TAPE ! !*********************************************************************** ! COMMON DUM(100510) COMMON/CLINE/INPAR CHARACTER(LEN=100) INPAR COMMON/CLINE1/ILENP COMMON/INDAT/IOPT,NLABEL,EDITIT,IFULL INTEGER EDITIT COMMON/REQUST/MATN(50),ZAN(50),MFN(50,25),IFILE(50),NCARD,KCARD COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/HEAD1/ZAH,AWRH,L1H,L2H,N1H,N2H,MATH,MFH,MTH COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN ! PARAMETER (MAXFIL=25,MXFIL=50) CHARACTER(LEN=66) STOR !+++MDC+++ !...VMS, WIN INTEGER*2 ILENP2 !---MDC--- CHARACTER(LEN=4 ) VERSION DATA VERSION/'6.13'/ ! ! DEFINE LIMITS FOR THE MINIPAGE VALUES ! MAXY = 5000 ! ! INITIALIZE FILE UNITS ! INPUT = 5 OTPUT = 6 ITAPE = 20 NSCR = 23 ! ! OUTPUT PROGRAM IDENTIFICATION ! WRITE(OTPUT,'(/A)') ' PROGRAM LISTEF VERSION '//VERSION ! ! CHECK FOR COMMAND LINE OPERATION ! INPAR = ' ' ILENP = 0 !+++MDC+++ !...VMS !/ CALL LIB$GET_FOREIGN(INPAR,,ILENP2) !/ ILENP = ILENP2 !...WIN CALL GETARG(1,INPAR,ILENP2) ILENP = IMAX0(ILENP2,0) !---MDC--- ! ! INITIALIZE FOR RUN ! 10 SOUT = 6 OUTPUT = 0 CALL BEGIN(IQUIT) IF(IQUIT.EQ.-1) GO TO 10 IF(IQUIT.EQ.1) GO TO 805 ! ! IF TAPE REQUEST LABEL IS LESS THAN ZERO DO NOT READ OR WRITE TPID ! IF(NLABEL.LT.0) GO TO 100 ! ! READ TAPE I.D. AND CHECK IF REQUESTED ! CALL TEXTR(ITAPE,STOR,LLABEL,MFL,MTL) IF(MFL.EQ.0.AND.MTL.EQ.0) GO TO 18 REWIND (UNIT=ITAPE) WRITE(OTPUT,17) 17 FORMAT(/' TAPE IS UNLABELED ') GO TO 100 18 IF(NLABEL.GT.0) GO TO 20 NLABEL = LLABEL GO TO 50 20 IF(NLABEL.EQ.LLABEL) GO TO 50 WRITE(OTPUT,30) 30 FORMAT(/' TAPE LABEL DOES NOT MATCH REQUEST LABEL--EXECUTION ', & & 'TERMINATED') GO TO 800 ! ! WRITE TAPE I.D. ! 50 IF(OUTPUT.GT.0) WRITE(OUTPUT,60) STOR,NLABEL 60 FORMAT(/' LABEL FROM DATA TAPE IS LISTED BELOW'//' ',A66,I4) ! ! READ HEAD CARD FOR FILE 1 OF CURRENT MATERIAL ! 100 CALL CONT(ITAPE,ZAH,AWRH,L1H,L2H,N1H,N2H,MATH,MFH,MTH) ! ! TEST FOR END OF FILE ON ITAPE ! IF(MATH.LT.0) GO TO 600 IF(MATH.EQ.0) GO TO 680 ! ! DETERMINE IF THIS DATA SET IS ON LIST OF THOSE TO BE LISTED ! 130 IF(NCARD.EQ.0) GO TO 250 DO 150 I=1,KCARD IF(MATN(I).EQ.MATH.OR.ZAN(I).EQ.ZAH) GO TO 160 150 CONTINUE ! ! THIS DATA SET HAS NOT BEEN REQUESTED. SKIP OVER IT ! CALL SKPMAT(ITAPE) GO TO 100 ! ! SET INDICATORS TO LIST THOSE FILES LISTED ON THE I-TH CARD ! 160 DO KEY=1,MXFIL IFILE(KEY)=0 END DO DO KEY=1,MAXFIL IF(MFN(I,KEY).LE.0) GO TO 200 LFN=MFN(I,KEY) IFILE(LFN)=1 END DO ! ! SHORTEN REQUEST LIST ! 200 DO KEY=1,MAXFIL MFN(I,KEY)=MFN(KCARD,KEY) END DO MATN(I)=MATN(KCARD) ZAN(I)=ZAN(KCARD) KCARD=KCARD-1 ! ! LIST FILE ONE ! 250 CALL FILE1(IFILE(1),IFILE(3)) ! ! READ FIRST RECORD OF FILE MFI ! 300 CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI) IF(MATI.LT.0) GO TO 680 IF(MATI.EQ.0) GO TO 575 ! ! TEST LIST OPTION FOR FILE MFI ! SELECT CASE (MFI) CASE (2) CALL FILE2 CASE (3) CALL FILE3 CASE (4) CALL FILE4 CASE (5) CALL FILE5 CASE (6) CALL FILE6 CASE (7) CALL FILE7 CASE (8) CALL FILE8 CASE (9,10) CALL FILE9 CASE (12,13) CALL FILE12 CASE (14) CALL FILE14 CASE (15) CALL FILE15 CASE (23,27) CALL FILE23 CASE(26) CALL FILE26 CASE (28) CALL FILE28 CASE (31,33) CALL FILE33 CASE (32) CALL FILE32 CASE (34) CALL FILE34 CASE (35) CALL FILE35 CASE (40) CALL FILE40 CASE DEFAULT CALL SKPFIL(ITAPE) END SELECT GO TO 300 ! ! END OF MATERIAL ENCOUNTERED. DETERMINE IF ALL DATA SETS PROCESSED ! 575 IF(NCARD.LE.0) GO TO 100 IF(KCARD.GT.0) GO TO 100 GO TO 650 ! ! END OF RUN ! 600 IF(KCARD.LT.1) GO TO 650 ! ! WRITE LIST OF UNFULLFILLED REQUESTS ! IF(OUTPUT.GT.0) WRITE(OUTPUT,610) (MATN(I),ZAN(I),I=1,KCARD) 610 FORMAT('1','All input data has been processed. The following ', & & 'requests were not filled since no matching MAT or ZA was found'/& & /' MAT ZA'/(I6,F10.0)) GO TO 800 ! ! ALL DATA SETS REQUESTED HAVE BEEN PROCESSED. WRITE COMPLETION ! MESSAGE ! 650 IF(OUTPUT.GT.0) WRITE(OUTPUT,660) 660 FORMAT('1','All data sets requested have been processed.') GO TO 800 ! ! ERROR ON TAPE. WRITE ERROR MESSAGE AND STOP ! 680 WRITE(OTPUT,690) 690 FORMAT(/' MATERIAL NUMBER IS LESS THAN OR EQUAL TO ZERO---', & & 'EXECUTION TERMINATED') ! ! CLOSE FILES ! 800 CLOSE(UNIT=ITAPE) IF(OTPUT.NE.SOUT) CLOSE(UNIT=SOUT) IF(OUTPUT.NE.0) CLOSE(UNIT=OUTPUT) GO TO 10 ! ! TERMINATE JOB ! 805 WRITE(OTPUT,'(/A)') ' ' STOP ' JOB COMPLETED SUCCESSFULLY' END ! !*********************************************************************** ! SUBROUTINE BEGIN(IQUIT) ! ! ROUTINE TO SET UP JOB ! COMMON/CLINE/INPAR CHARACTER(LEN=100) INPAR COMMON/CLINE1/ILENP COMMON/INDAT/IOPT,NLABEL,EDITIT,IFULL INTEGER EDITIT COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN ! LOGICAL IEXIST CHARACTER(LEN=50) INFIL,SOUFIL,OUFIL CHARACTER(LEN=1) IW CHARACTER(LEN=80) DATIN CHARACTER(LEN=4) BUF DATA IONEPASS/0/ ! ! SEE IF ONE PASS LIMIT SET ! IF(IONEPASS.EQ.1) THEN IQUIT = 1 GO TO 100 END IF ! ! INITIALIZE ! NCONT = 0 IQUIT = 0 IFULL = 0 INFIL = '*' SOUFIL = '*' OUFIL = '*' IW = '*' ! ! INITIALIZE INPUT PARAMATERS ! NLABEL = 0 IOPT = 1 EDITIT = 1 ! !+++MDC+++ !...VMS, WIN IF(ILENP.NE.0) THEN CALL TOKEN(INPAR,'/',1,INFIL) CALL TOKEN(INPAR,'/',2,SOUFIL) CALL TOKEN(INPAR,'/',3,OUFIL) CALL TOKEN(INPAR,'/',4,IW) IF(IW.EQ.' ') IW = 'Y' IONEPASS = 1 ELSE IW = '*' END IF !---MDC--- ! ! GET FILE SPECIFICATIONS ! IF(INFIL.EQ.'*') THEN !+++MDC+++ !...VMS, WIN, UNX WRITE(OTPUT,'(/A,$)') & & ' Input File Specification - ' !---MDC--- READ(INPUT,'(A)') INFIL !+++MDC+++ !...ANS !/ WRITE(OTPUT,'(/2A)') ' Input file - ',INFIL !---MDC--- ELSE WRITE(OTPUT,'(/2A)') ' Input file - ',INFIL END IF CALL UPSTR(INFIL) IF(INFIL.EQ.' '.OR.INFIL.EQ.'DONE') THEN IQUIT = 1 GO TO 100 END IF INQUIRE(FILE=INFIL,EXIST=IEXIST) IF(.NOT.IEXIST) THEN WRITE(OTPUT,'(/A/)') ' COULD NOT FIND INPUT FILE' !+++MDC+++ !...VMS, WIN, UNX IF(IONEPASS.EQ.1) THEN IQUIT = 1 ELSE IQUIT = -1 END IF !...ANS !/ IQUIT = 1 !---MDC--- GO TO 100 END IF IF(SOUFIL.EQ.'*' ) THEN !+++MDC+++ !...VMS, WIN, UNX WRITE(OTPUT,'(/A,$)') & & ' Output Summary File Specification - ' !---MDC--- READ(INPUT,'(A)') SOUFIL !+++MDC+++ !...ANS !/ WRITE(OTPUT,'(/2A)') ' Output Summary File - ',SOUFIL !---MDC--- ELSE WRITE(OTPUT,'(/2A)') ' Output Summary File - ',SOUFIL END IF IF(SOUFIL.NE.' ') SOUT = 21 CALL UPSTR(SOUFIL) IF(OUFIL.EQ.'*' ) THEN !+++MDC+++ !...VMS, WIN, UNX WRITE(OTPUT,'(/A,$)') ' Output Full File Specification - ' !---MDC--- READ(INPUT,'(A)') OUFIL !+++MDC+++ !...ANS !/ WRITE(OTPUT,'(/2A)') ' Output Full File - ',OUFIL !---MDC--- ELSE WRITE(OTPUT,'(/2A)') ' Output Full File - ',OUFIL END IF IF(OUFIL.NE.' ') THEN IFULL = 1 OUTPUT = 22 CALL UPSTR(OUFIL) END IF ! ! CHECK IF STANDARD OPTIONS ARE WANTED ! IF(IW.EQ.'*') THEN !+++MDC+++ !...VMS, WIN, UNX 10 WRITE(OTPUT,'(/A,$)') ' Standard Options (Y(es),N(o),?) ' READ(INPUT,'(A)') IW CALL UPSTR(IW) IF(IW.EQ.'?') THEN IW = '*' WRITE(OTPUT,15) 15 FORMAT(10X,' STANDARD OPTIONS ARE'/ & & 10X,' ONE SECTION/PAGE '/ & & 10X,' LIST ENTIRE TAPE') GO TO 10 END IF !...ANS !/ READ(INPUT,'(A)') DATIN !/ IF(DATIN.EQ.' ') THEN !/ IW = 'Y' !/ ELSE !/ IW = 'N' !/ END IF !---MDC--- END IF ! ! NON STANDARD OPTIONS ! IF(IW.EQ.'N') THEN ! ! EDIT ONE SECTION PER PAGE ! !+++MDC+++ !...VMS, WIN, UNX WRITE(OTPUT,'(/A,$)') & & ' Edit One Section per Page (Y(es),N(o)) ' READ(INPUT,'(A)') IW !...ANS !/ CALL TOKEN(DATIN,',',1,BUF) !/ IW = BUF(1:1) !---MDC--- CALL UPSTR(IW) IF(IW.EQ.'N') EDITIT = 0 ! ! LIST ENTIRE TAPE ! !+++MDC+++ !...VMS, WIN, UNX WRITE(OTPUT,'(/A,$)') & & ' List Entire Tape (Y(es),N(o)) ' READ(INPUT,'(A)') IW !...ANS !/ CALL TOKEN(DATIN,',',2,BUF) !/ IW = BUF(1:1) !---MDC--- CALL UPSTR(IW) IF(IW.EQ.'N') IOPT = 0 END IF IF(EDITIT.EQ.0) THEN WRITE(OTPUT,'(/6X,A)') & & 'Output will NOT be Edited to One Section per Page.' ELSE WRITE(OTPUT,'(/6X,A)') & & 'Output will be Edited to One Section per Page.' END IF IF(IOPT.EQ.1) THEN WRITE(OTPUT,'(6X,A)') 'Process the Entire Tape' END IF ! ! OPEN INPUT AND OUTPUT FILES ! OPEN(UNIT=ITAPE,ACCESS='SEQUENTIAL',STATUS='OLD',ACTION='READ', & & FILE=INFIL) IF(SOUT.NE.6) THEN !...VMS OPEN(UNIT=SOUT,ACCESS='SEQUENTIAL',STATUS='NEW',FILE=SOUFIL) !...ANS, WIN, UNX !/ OPEN(UNIT=SOUT,ACCESS='SEQUENTIAL',STATUS='UNKNOWN', !/ 1 FILE=SOUFIL) !---MDC--- END IF IF(IFULL.NE.0) THEN !+++MDC+++ !...VMS !/ OPEN(UNIT=OUTPUT,ACCESS='SEQUENTIAL',STATUS='NEW',FILE=OUFIL) !...ANS, WIN, UNX OPEN(UNIT=OUTPUT,ACCESS='SEQUENTIAL', & & STATUS='UNKNOWN',FILE=OUFIL) !---MDC--- END IF ! ! GET AND OUTPUT DETAILS OF MATERIALS SELECTED ! CALL REQUES ! ! OUTPUT SELECTED OPTIONS ! IF(OUTPUT.GT.0) THEN WRITE(OUTPUT,'(A//)') '1' WRITE(OUTPUT,'(2A)') & & ' Input File Specification------------------------',INFIL IF(EDITIT.EQ.0) THEN WRITE(OUTPUT,'(A)') & & ' Output will NOT be Edited to One Section per Page.' ELSE WRITE(OUTPUT,'(A)') & & ' Output will be Edited to One Section per Page.' END IF IF(IOPT.EQ.1) THEN WRITE(OUTPUT,'(A)') ' Process the Entire Tape' END IF END IF ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE REQUES ! ! ROUTINE TO SET SPECIFICATIONS FOR PARTS OF TAPE TO BE PROCESSED ! COMMON/INDAT/IOPT,NLABEL,EDITIT,IFULL INTEGER EDITIT COMMON/REQUST/MATN(50),ZAN(50),MFN(50,25),IFILE(50),NCARD,KCARD COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT ! PARAMETER (MAXMAT=50) CHARACTER(LEN=80) CARD CHARACTER(LEN=4) BUF CHARACTER(LEN=6) BUF1 ! PARAMETER (MAXFIL=25) INTEGER MFNT(MAXFIL) PARAMETER (KRANGE=6) INTEGER MRANGE(2,KRANGE) DATA MRANGE/1,7,8,10,12,15,23,23,26,28,31,33/ ! ! INITIALIZE ! NCARD = 0 DO I=1,MAXMAT MATN(I) = 0 ZAN(I) = 0. IFILE(I) = 0 DO J=1,MAXFIL MFN(I,J) = 0 END DO END DO ! ! SET UP FOR ENTIRE TAPE PROCESSING ! IF(IOPT.NE.0) THEN JJ = 0 DO J=1,KRANGE K1 = MRANGE(1,J) K2 = MRANGE(2,J) DO K=K1,K2 JJ = JJ + 1 IFILE(K) = 1 MFN(1,JJ) = K END DO END DO IF(OUTPUT.GT.0) THEN WRITE(OUTPUT,'(/2A/)') & & ' The following files have been requested for all data ', & & 'sets on the tape.' WRITE(OUTPUT,'(15I5)') (MFN(1,K),K=1,JJ) END IF GO TO 100 END IF ! ! PARTIAL TAPE PROCESSING ! !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! ! MATN(I)=IDENTIFICATION NUMBER FOR DATA SET ! ZAN(I) =(Z,A) NUMBER FOR DATA SET ! MFN(I,J)=LIST OF FILES TO BE LISTED. PERMISSIBLE NUMBERS ARE... ! 1 TO 7 NEUTRON INTERACTION DATA ! 8 TO 10 RADIOACTIVE DECAY DATA ! 12 TO 15 PHOTON PRODUCTION DATA ! 23 AND 26 TO 28 PHOTON INTERACTION DATA ! 31 TO 33 ERROR FILES ! IF NO FILES ARE REQUESTED ONLY HOLLERITH DATA IS SUPPLIED ! !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! !+++MDC+++ !...VMS, WIN, UNX DO I=1,MAXFIL MFNT(I) = 0 END DO WRITE(OTPUT,'(/2A/A/)') ' Enter MAT or ZA and FILE Numbers', & & ' for each material to be listed,', & & ' one line per material. Terminate with MAT=0 or ZA=0.0' !---MDC--- ! ! READ EACH DATA SET IDENTIFICATION ! DO I=1,MAXMAT !+++MDC+++ !...VMS, WIN, UNX 10 WRITE(OTPUT,'(A,$)') ' * ' !...ANS !/ 10 CONTINUE !---MDC--- MATN(I) = 0 ZAN(I) = 0.0 READ(INPUT,'(A)') CARD IF(CARD.EQ.' ') GO TO 50 CALL TOKEN(CARD,',',1,BUF1) IF(INDEX(BUF1,'.').NE.0) THEN READ(BUF1,'(BN,F6.0)',ERR=10) ZAN(I) ELSE BUF = BUF1(1:4) READ(BUF(1:4),'(BN,I4)',ERR=10) MATN(I) END IF IF(MATN(I).EQ.0.AND.ZAN(I).EQ.0.0) GO TO 50 DO J=1,MAXFIL CALL TOKEN(CARD,',',J+1,BUF) READ(BUF,'(BN,I2)',ERR=10) MFNT(J) END DO ! ! ELIMINATE ALL FILE REQUESTS THAT ARE NOT IN A LEGAL RANGE ! JJ = 0 DO J=1,MAXFIL MFNTT = MFNT(J) DO K=1,KRANGE IF(MFNTT.GE.MRANGE(1,K).AND.MFNTT.LE.MRANGE(2,K)) THEN JJ=JJ+1 MFN(I,JJ) = MFNTT GO TO 30 END IF END DO 30 END DO END DO I = MAXMAT + 1 50 NCARD = I - 1 KCARD = NCARD ! ! OUTPUT SUMMARY OF DATA TO BE LISTED ! IF(NCARD.LE.0) THEN IF(OUTPUT.GT.0) THEN WRITE(OUTPUT,'(/2A)') & & ' Only hollerith information for all data sets on the ', & & 'tape has been requested' END IF GO TO 100 END IF ! ! SPECIFIC MATERIALS AND FILES REQUESTED ! IF(OUTPUT.GT.0) THEN WRITE(OUTPUT,'(/A//A)') & & ' The following data has been requested', & & ' MAT ZA FILES' END IF DO I=1,NCARD DO J=1,MAXFIL IF(MFN(I,J).EQ.0) GO TO 60 END DO J = MAXFIL + 1 60 J = J - 1 IF(OUTPUT.GT.0) THEN IF(J.GT.0) THEN WRITE(OUTPUT,'(I5,F10.0,5X,20I5)') & & MATN(I),ZAN(I),(MFN(I,K),K=1,J) ELSE WRITE(OUTPUT,'(I5,F10.0,5X,A)') & & MATN(I),ZAN(I),' Only hollerith' END IF END IF END DO ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE UPSTR(STRING) ! ! ROUTINE TO CONVERT A STRING TO ALL UPPER CASE ! CHARACTER(LEN=*) STRING ! L = LEN(STRING) DO I=1,L IC = ICHAR(STRING(I:I)) IF(IC.GT.96.AND.IC.LT.123) STRING(I:I) = CHAR(IC-32) END DO ! RETURN END ! !*********************************************************************** ! SUBROUTINE TOKEN(INSTR,DELIM,ITOK,OUTSTR) ! ! SUBROUTINE TO EXTRACT A STRING FROM A STRING WITH DELIMITERS ! CHARACTER(LEN=*) INSTR,OUTSTR,DELIM ! ! INITIALIZE ! OUTSTR = ' ' ILEN = LEN_TRIM(INSTR) JLEN = LEN_TRIM(DELIM) IF(ITOK.EQ.0.OR.ILEN.EQ.0) GO TO 100 IF(JLEN.EQ.0) THEN IF(ITOK.EQ.1) OUTSTR = INSTR GO TO 100 END IF ! ! FIND ITOK-TH DELIMITER ! ITOKP = 1 - JLEN DO I=1,ITOK IBEG = ITOKP + JLEN IF(IBEG.LE.ILEN) THEN ITOKP = INDEX(INSTR(IBEG:),DELIM) + IBEG - 1 IF(ITOKP.LT.IBEG) ITOKP = ILEN + 1 ELSE GO TO 100 END IF IF(I.EQ.ITOK) THEN IF(ITOKP.GT.IBEG) OUTSTR = INSTR(IBEG:ITOKP-1) GO TO 100 END IF END DO ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE1(ICOMP,IFILE3) ! ! ROUTINE TO CONTROL PROCESSING OF FILE 1 DATA ! COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR COMMON/TOPR/EMAX,ELIS,STA,LIS,LISO COMMON/HEAD1/ZAH,AWRH,LRP,LFI,N1H,N2H,MATH,MFH,MTH COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI ! ! PROCESS REMAINING IDENTIFICATION CARDS IN FILE 1 SECTION 451 ! NLIB=N1H NMOD=N2H MATIN = MATH CALL CONT(ITAPE,ELIS,STA,LIS,LISO,N1,NFOR,MAT,MF,MT) IF(NFOR.NE.0) GO TO 20 ! ! ENDF-V FORMAT FILE ! NFOR = 5 NVER = 5 NREL = 0 IF((NLIB.GE.2.AND.NLIB.LE.4).OR.NLIB.EQ.35) NVER = 1 IF(NLIB.EQ.5) NVER = 2 IF(NLIB.EQ.6) NVER = 3 NSUB = 10 AWI = 1. GO TO 30 ! ! ENDF-VI OR LATER FORMAT ! 20 CALL CONT(ITAPE,AWI,EMAX,NREL,L2,NSUB,NVER,MAT,MF,MT) IF(EMAX.EQ.0.0) EMAX = 2.E+7 ! ! PROCESS COMMENTS AND DIRECTORY ! 30 CALL HEADIN(MATH,MFH,0,ZAH) MFBCD = ' General Information' CALL IDDATA IF(LRP.EQ.1.AND.IFILE3.EQ.1) CALL BANNER(LFI) CALL FILE1A ! ! SKIP REST OF FILE ONE UNLESS PROCESSING REQUESTED ! IF(ICOMP.EQ.1) GO TO 40 CALL SKPFIL(ITAPE) GO TO 100 40 IREST1 = 0 ! ! PROCESS REMAINING SECTIONS OF FILE 1 ! 50 CALL CONT(ITAPE,ZA,AWR,L1I,L2I,N1I,N2I,MATI,MFI,MTI) IF(MFI.EQ.0) GO TO 100 ! ! PROCESS NEXT SECTION ! IF(IREST1.EQ.0) THEN CALL FILEHD(1) IREST1 = 1 END IF CALL HEADIN(0,0,MTI,-1.) SELECT CASE (MTI) ! ! NUBAR ! CASE (452,455,456) NWI = 0 IF(MTI.EQ.455) NWI = 1 CALL FILE1B(NWI) ! ! ENERGY RELEASE IN FISSION ! CASE (458) CALL FILE1C ! ! SKIP SECTION WHICH CANNOT BE RECOGNIZED ! CASE DEFAULT CALL SKPSEC(ITAPE) GO TO 50 END SELECT CALL SKPREC(ITAPE,1) GO TO 50 ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE BANNER(LFI) ! ! ROUTINE TO PUT OUT WARNING BANNER IF FILE 3 IS LISTED AND THERE ! ARE RESONANCE PARAMETERS TO BE ADDED ! COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT ! PARAMETER (NLINES=7) CHARACTER(LEN=46) LINE(NLINES) CHARACTER(LEN=46) LINE3(2) ! DATA LINE/'This material contains resonance parameters.', & & 'The cross sections given in file 3 for', & & ' ', & & 'in the resonance region are background files', & & 'which must be added to the cross section', & & 'calculated from the resonance parameters', & & 'to give the real cross section. '/ DATA LINE3/' Total, Elastic, and Gamma production ', & & 'Total, Elastic, Fission, and Gamma production'/ ! ! SET PROPER LINE 3 IF FISSIONABLE ! LINE(3) = LINE3(1) IF(LFI.EQ.1) LINE(3) = LINE3(2) ! ! OUTPUT TEXT ! IF(OUTPUT.GT.0) WRITE(OUTPUT,10) 10 FORMAT(/////////27X,80('*')/27X,'*',78X,'*'/27X,'*',78X,'*') DO 50 I=1,NLINES IF(OUTPUT.GT.0) WRITE(OUTPUT,25) LINE(I) 25 FORMAT(27X,'*',16X,A46,16X,'*') 50 CONTINUE IF(OUTPUT.GT.0) WRITE(OUTPUT,60) 60 FORMAT(27X,'*',78X,'*'/27X,'*',78X,'*'/27X,80('*')) ! RETURN END ! !*********************************************************************** ! SUBROUTINE IDDATA ! ! ROUTINE TO OUTPUT MATERIAL IDENTIFICATION ! COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/HEAD1/ZAH,AWRH,LRP,LFI,N1H,N2H,MATH,MFH,MTH COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR COMMON/TOPR/EMAX,ELIS,STA,LIS,LISO ! CHARACTER(LEN=11) ADATE CHARACTER(LEN=20) ZAPART ! PARAMETER (NPARTS=7) CHARACTER(LEN=8) PNAMES(NPARTS) INTEGER IPZA(NPARTS) CHARACTER(LEN=16) GTEXT(2) ! DATA PNAMES/'PHOTON ','NEUTRON ','ELECTRON','PROTON ', & & 'DEUTERON','TRITON ','ALPHA '/ DATA IPZA/0,1,11,1001,1002,1003,2004/ DATA GTEXT/'GROUND State','METASTABLE State'/ ! ! SET LIBRARY ID ! CALL LIBID(NLIB,NVER,LIBBCD) ! ! GET TODAY'S DATE ! CALL DATE_20(ADATE) ! ! OUTPUT IDENTIFICATION FOR MATERIAL ! IF(OUTPUT.GT.0) WRITE(OUTPUT,20) ADATE,ZABCD,MATIN,NSUB,NMOD, & & LIBBCD,NREL,NFOR WRITE(SOUT,20) ADATE,ZABCD,MATIN,NSUB,NMOD,LIBBCD,NREL,NFOR 20 FORMAT('1',100X,A11///2X,A24,' Material No. ',I4,', ', & & 'Sub-library No. ',I6,', ','Mod No. ',I2,', ',A14, & & ' Release No. ',I2,', ',' Format ENDF-',I1) ! ! DETERMINE INCIDENT PARTICLE NAME ! IPART = NSUB/10 DO 40 I=1,NPARTS IF(IPART.EQ.IPZA(I)) GO TO 45 40 CONTINUE CALL ZAID(FLOAT(IPART),ZAPART,IERR) GO TO 50 45 ZAPART = PNAMES(I) GO TO 55 50 IF(IPART.NE.0) GO TO 55 IF(NSUB.EQ.4.OR.NSUB.EQ.5) ZAPART = 'NONE' ! ! OUTPUT PROJECTILE ID AND TARGET STATE ! 55 IF(OUTPUT.GT.0) WRITE(OUTPUT,60) ZAPART WRITE(SOUT,60) ZAPART 60 FORMAT(/30X,'Projectile is ',A20) IGM = MIN0(LISO,1) + 1 ELISM = ELIS/1.E+6 IF(OUTPUT.GT.0) WRITE(OUTPUT,65) GTEXT(IGM),ELISM WRITE(SOUT,65) GTEXT(IGM),ELISM 65 FORMAT(30X,'Target in ',A16,' E(level) = ',F8.4,' MeV') IF(NFOR.GT.5) THEN EMAXM = EMAX/1.E+6 IF(OUTPUT.GT.0) WRITE(OUTPUT,70) EMAXM WRITE(SOUT,70) EMAXM 70 FORMAT(30X,'Maximum Incident Energy ',16X,'= ',1PG10.4,' MeV') END IF IF(LFI.GT.0) THEN IF(OUTPUT.GT.0) WRITE(OUTPUT,75) WRITE(SOUT,75) 75 FORMAT(30X,'Target is FISSIONABLE') END IF IF(LRP.GT.0) THEN IF(OUTPUT.GT.0) WRITE(OUTPUT,85) WRITE(SOUT,85) 85 FORMAT(30X,'RESONANCE PARAMETERS are given') END IF IF(OUTPUT.GT.0) WRITE(OUTPUT,100) WRITE(SOUT,100) 100 FORMAT(/) ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE1A ! ! ROUTINE TO PROCESS MT = 451 ! COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR ! PARAMETER (LPPAGE=59) CHARACTER(LEN=66) HOL CHARACTER(LEN=132) FHOL CHARACTER(LEN=33) STEXT ! CHARACTER(LEN=30) DICTON PARAMETER (NHEADS=6) INTEGER HLENL(NHEADS) INTEGER HLENU(NHEADS) CHARACTER(LEN=23) HEADS(NHEADS) ! DATA DICTON/' Table of Contents '/ ! DATA HEADS/'Laboratory-------------', & & 'Evaluation date--------', & & 'Author(s)--------------', & & 'Reference(s)-----------', & & 'Distribution date------', & & 'Revision date(s)-------'/ DATA HLENL/12,28,34,68,94,105/ DATA HLENU/22,32,66,88,98,109/ ! ! READ CONTROL CARD ! CALL CONT(ITAPE,C1,C2,L1,L2,NCD,NXC,MAT,MF,MT) ! ! PROCESS EACH TEXT CARD ! IF(NCD.LE.0) GO TO 37 DO 25 N=1,NCD !*****OUTPUT NEW PAGE IF(OUTPUT.GT.0.AND.MOD(N,LPPAGE).EQ.1) WRITE(OUTPUT,10) 10 FORMAT('1') CALL TEXTR(ITAPE,HOL,MAT,MF,MT) IF(N.GT.2) GO TO 15 NB = 66*(N-1) + 1 NE = NB + 65 FHOL(NB:NE) = HOL 15 IF(OUTPUT.GT.0) WRITE(OUTPUT,20) HOL 20 FORMAT(30X,A66) 25 CONTINUE ! ! OUTPUT TO SUMMARY STRUCTURED FREE TEXT INFORMATION ! DO 32 K=1,NHEADS IB = HLENL(K) IU = HLENU(K) STEXT = FHOL(IB:IU) WRITE(SOUT,30) HEADS(K),STEXT 30 FORMAT(43X,A23,1X,A33) 32 CONTINUE ! ! OUTPUT SUMMARY FOR 451 ! WRITE(SOUT,35) NCD,NXC 35 FORMAT(//30X,'Total number of COMMENT RECORDS: ',I3/ & & 30X,'Total number of DATA SECTIONS: ',I3) ! ! PROCESS THE DIRECTORY IF PRESENT ! 37 IF(NXC.LE.0) GO TO 100 MTBCD = DICTON ! ! WRITE DIRECTORY HEADING FOR SUMMARY ! WRITE(SOUT,38) 38 FORMAT(//58X,'TABLE OF CONTENTS'//57X,'Section Numbers(MOD)'/ & & 32X,10(' ------')) ! ! WRITE PAGE LABEL ! CALL TOPAGE ! ! WRITE TABLE COLUMN HEADINGS ! IF(OUTPUT.GT.0) WRITE(OUTPUT,40) 40 FORMAT(29X,'Data Type',36X,'Reaction',17X,'Records',5X, & & 'MOD Number'/) ! ! WRITE TWO TABLE ENTRIES FOR FREE TEXT AND TABLE OF CONTENTS ! CALL CONT(ITAPE,C1,C2,MFZ,MTZ,NCZ,NMODZ,MAT,MF,MT) NCZ=NCZ-NXC CALL MTID(NFOR,NSUB,MTZ,MTBCD,IERR) IF(OUTPUT.GT.0) WRITE(OUTPUT,45) MFBCD,MTBCD,NCZ,NMODZ 45 FORMAT(10X,A48,5X,A30,2I11) MTBCD = DICTON MFBCD = ' ' IF(OUTPUT.GT.0) WRITE(OUTPUT,45) MFBCD,MTBCD,NXC,NMODZ ! ! INITIALIZE FILE ! MFX=1 CALL DIROUT(SOUT,MFZ,MTZ,NMODZ) IF(NXC.LT.2) GO TO 90 ! ! SET UP LOOP OVER REMAINING DIRECTORY CARDS ! DO 80 I=2,NXC CALL CONT(ITAPE,C1,C2,MFZ,MTZ,NCZ,NMODZ,MAT,MF,MT) ! ! IF FILE NUMBER HAS CHANGED COMPUTE NEW HOLLERITH ! IF(MFZ.NE.MFX) GO TO 50 MFBCD = ' ' CALL DIROUT(SOUT,0,MTZ,NMODZ) GO TO 60 50 CALL MFID(NSUB,MFZ,MTZ,MFBCD,IERR) MFX = MFZ CALL DIROUT(SOUT,MFZ,MTZ,NMODZ) ! ! COMPUTE NEW HOLLERITH FOR REACTION ! 60 CALL MTID(NFOR,NSUB,MTZ,MTBCD,IERR) ! ! WRITE HOLLERITH EQIVALENTS OF FILE AND REACTION PLUS CARD COUNT ! IF(OUTPUT.GT.0) WRITE(OUTPUT,45) MFBCD,MTBCD,NCZ,NMODZ 80 CONTINUE ! ! DUMP REMAINING DIRECTORY SUMMARY ! 90 CALL DIROUT(SOUT,99,0,0) ! ! RESTORE FILE IDENTIFICATION ! CALL HEADIN(0,1,451,-1.) ! ! SKIP SEND CARD ! 100 CALL SKPREC(ITAPE,1) ! RETURN END ! !*********************************************************************** ! SUBROUTINE DIROUT(OUT,IFILE,MT,SMOD) ! ! ROUTINE TO BUILD AND BUFFER OUT DIRECTORY SUMMARY ! INTEGER OUT,SMOD CHARACTER(LEN=8) FSTRNG CHARACTER(LEN=70) DSTRNG CHARACTER(LEN=7) TSTRNG ! !+++MDC+++ !...ANS !/ SAVE NEXT,FSTRNG,DSTRNG !---MDC--- ! DATA NEXT/0/ ! ! START OF NEW LINE REQUIRED ! IF(IFILE.EQ.1) GO TO 30 IF(IFILE.EQ.0.AND.NEXT.LT.70) GO TO 50 IF(FSTRNG.EQ.' ') THEN WRITE(OUT,10) DSTRNG 10 FORMAT(33X,A70) ELSE WRITE(OUT,20) FSTRNG,DSTRNG 20 FORMAT(/23X,A8,2X,A70) END IF IF(IFILE.EQ.100) GO TO 100 ! ! INITIALIZE A NEW LINE ! 30 NEXT = 1 DSTRNG = ' ' FSTRNG = ' ' ! ! SET UP NEXT FILE ID ! IF(IFILE.EQ.0) GO TO 50 WRITE(FSTRNG,40) IFILE 40 FORMAT('FILE#',I3) ! ! ADD NEW SECTION ! 50 WRITE(TSTRNG,60) MT,SMOD 60 FORMAT(I3,'(',I1,') ') DSTRNG(NEXT:NEXT+6) = TSTRNG NEXT = NEXT + 7 ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE1B(NDEL) ! ! PROCESS NUBAR ! COMMON A(100),C(10),NBT(200),INT(200),X(50000),Y(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/HEADI/ZAI,AWRI,L1I,LNU,N1I,N2I,MATI,MFI,MTI ! PARAMETER (IBASE=0,ERANGE=2.0E+10) ! CHARACTER(LEN=24) HEAD CHARACTER(LEN=24) UNIT CHARACTER(LEN=4) DEGREE(6) ! DATA HEAD/' Energy NU '/ DATA UNIT/' eV '/ DATA DEGREE/'ZERO','1-ST','2-ND','3-RD','4-TH','5-TH'/ ! ! WRITE PAGE HEADING ! CALL TOPAGE ! ! READ AND OUTPUT DECAY CONSTANTS ! IF(MTI.NE.455) GO TO 20 CALL CANT(ITAPE,C1,C2,L1,L2,NNF,N2,MAT,MF,MT,A) IF(OUTPUT.GT.0) WRITE(OUTPUT,10) 10 FORMAT(/6X,'Decay Constants'/11X,'(1/sec)'/) IF(OUTPUT.GT.0) WRITE(OUTPUT,15) (A(I),I=1,NNF) 15 FORMAT(9X,1PE11.4) ! ! BRANCH ON DATA FORMAT ! 20 IF(LNU.NE.1) GO TO 150 ! ! DATA IS POLYNOMIAL COEFFICIENTS ! CALL CANT(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,C) NC = NR ! ! RECONSTRUCT POLYNOMIAL AT 200 EQUALLY SPACED POINTS ! DX=10.**(ALOG10(ERANGE)/200.) X(1)=10.E-3 DO I=1,201 ET = X(I) Y(I) = C(1) IF(NC.GE.2) THEN DO J=2,NC Y(I) = Y(I)+C(J)*ET ET = ET*X(I) END DO X(I+1)=X(I)*DX END IF 50 END DO NP = 201 ! ! OUTPUT POLYNOMIAL DATA ! IF(NC.GT.1) GO TO 120 IF(OUTPUT.GT.0.AND.NDEL.EQ.0) WRITE(OUTPUT,110) C(1) 110 FORMAT(/' The average number of neutrons per fission is CONSTANT',& & 1PE11.4) IF(OUTPUT.GT.0.AND.NDEL.EQ.1) WRITE(OUTPUT,115) C(1) 115 FORMAT(/' The average number of delayed neutrons per fission is ',& & 'CONSTANT',1PE11.4) GO TO 1000 120 NCM1=NC-1 IF(OUTPUT.GT.0) WRITE(OUTPUT,130) 130 FORMAT(/' Polynomial Coefficients for NU-BAR') IF(OUTPUT.GT.0) WRITE(OUTPUT,135) IBASE,C(1),(I,C(I+1),I=1,NCM1) 135 FORMAT(8(I3,1PE11.4)) IF(OUTPUT.GT.0) WRITE(OUTPUT,140) 140 FORMAT(/' Reconstructed Values of NU-BAR') GO TO 250 ! ! DATA IS TABULAR ! 150 CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL INTAB(NBT,INT,NR,1,OUTPUT) IF(OUTPUT.GT.0) WRITE(OUTPUT,210) 210 FORMAT(/' Tabulated Values of NU-BAR') ! ! OUTPUT TABLE ! 250 CALL WRTAB1(OUTPUT,HEAD,UNIT,X,Y,NP) ! ! OUTPUT TO SUMMARY TABLE ! IF(MTI.NE.455) GO TO 300 IF(LNU.EQ.1) WRITE(SOUT,260) MTI,MTBCD,DEGREE(NC),NNF 260 FORMAT(/I6,3X,A30,4X,'Specified by a ',A4,' DEGREE POLYNOMIAL', & & ' for ',I2,' groups') IF(LNU.EQ.2) WRITE(SOUT,270) MTI,MTBCD,NP,NR,NNF 270 FORMAT(/I6,3X,A30,4X,'Specified at ',I4,' ENERGY POINTS with ',I3,& & ' INTERPOLATION REGIONS for ',I2,' GROUPS') GO TO 1000 300 IF(LNU.EQ.1) WRITE(SOUT,310) MTI,MTBCD,DEGREE(NC) 310 FORMAT(/I6,3X,A30,4X,'Specified by a ',A4,' DEGREE POLYNOMIAL') IF(LNU.EQ.2) WRITE(SOUT,320) MTI,MTBCD,NP,NR 320 FORMAT(/I6,3X,A30,4X,'Specified at ',I4,' ENERGY POINTS with ', & & I3,' INTERPOLATION REGIONS') ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE1C ! ! ROUTINE TO PROCESS ENERGY RELEASE IN FISSION ! COMMON A(100),C(10),NBT(200),INT(200),X(50000),Y(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/HEADI/ZAI,AWRI,L1I,LNU,N1I,N2I,MATI,MFI,MTI ! CHARACTER(LEN=38) LINE(9) DATA LINE/'Fragment Kinetic Energy ', & & 'Prompt Fission Neutron Kinetic Energy ', & & 'Delayed Fission Neutron Kinetic Energy', & & 'Prompt Gamma-ray Emission ', & & 'Delayed Gamma-ray Emission ', & & 'Delayed Beta ', & & 'Neutrino ', & & 'Total Energy Less Neutrino Energy ', & & 'Total Energy Release per Fission '/ ! ! WRITE PAGE HEADING ! CALL TOPAGE ! ! READ IN DATA ! CALL CANT(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,A) ! ! OUTPUT HEADING ! IF(OUTPUT.GT.0) WRITE(OUTPUT,10) 10 FORMAT(//' Components of Energy Release Due to Fission', & & 13X,'Energy(eV/fission)'/5X,43('-'),13X,18('-')) NL = 1 DO I=1,NP IF(OUTPUT.GT.0) WRITE(OUTPUT,25) LINE(I),A(NL),A(NL+1) 25 FORMAT(10X,A38,10X,1PE12.5,' +/- ',1PE12.5,' eV/fission') NL = NL + 2 END DO ! ! OUTPUT TO SUMMARY ! WRITE(SOUT,75) MTI,MTBCD,A(NR-1) 75 FORMAT(/I6,3X,A30,4X,'Total Energy Release per Fission is', & & 1PE11.4,' EV') ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE2 ! ! ROUTINE TO PROCESS RESONANCE REGION DATA ! COMMON ZARI,ABN,LFW,NER,EL,EH,LRU,LRF,SPI,AP,NLS,NJS,QX(5),LRX(5),& & L(5),NJSA(5),AJ(20),NRS(20),JNT(20),AJL(6),MUF(6),NE(6),ES(250),& & RES(47728),NRO,NBT(200),INT(200),NR,X(1000),Y(1000),NP,C(18),NX,& & DUM(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/HEADI/ZAI,AWRI,L1I,L2I,NIS,N2I,MATI,MFI,MTI ! CHARACTER(LEN=24) ZAIBCD ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,MTI,-1.0) ! ! OUTPUT FILE HEADING FOR SUMMARY ! CALL FILEHD(MFI) WRITE(SOUT,5) MTBCD 5 FORMAT(/' 151',3X,A30) ! ! SET UP LOOP OVER ISOTOPES ! DO 200 I=1,NIS CALL CONT(ITAPE,ZARI,ABN,L1,LFW,NER,N2,MAT,MF,MT) ! ! OUTPUT ISOTOPE HEADING TO SUMMARY ! CALL ZAID(ZARI,ZAIBCD,IERR) WRITE(SOUT,10) ZAIBCD 10 FORMAT(//40X,'Isotope ',A24/40X,'-------') ! ! SET UP LOOP OVER ENERGY RANGES ! DO 180 JJ=1,NER J = JJ CALL CONT(ITAPE,EL,EH,LRU,LRF,NRO,N2,MAT,MF,MT) ! ! READ ENERGY DEPENDENT SCATTERING LENGTH ! IF(NRO.EQ.0) GO TO 20 CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) ! ! NO RESONANCE PARAMETERS GIVEN ! 20 IF(LRU.EQ.0) THEN CALL CONT(ITAPE,SPI,AP,L1,L2,NLS,N2,MAT,MF,MT) CALL LIST2H(J) GO TO 180 END IF ! ! RESONANCES ARE RESOLVED ! IF(LRU.EQ.2) GO TO 100 CALL CONT(ITAPE,SPI,AP,L1,L2,NLS,N2,MAT,MF,MT) CALL LIST2H(J) ! ! SINGLE - AND MULTI-LEVEL BREIT-WIGNER AND R-MATRIX PARAMETERS ! IF(LRF.EQ.4) GO TO 70 IF(LRF.EQ.6) GO TO 85 K4 = 1 DO III=1,NLS CALL CANT(ITAPE,C1,QX(III),L(III),LRX(III),NT,NRS(III), & & MAT,MF,MT,RES(K4)) K4 = K4 + NT END DO CALL LIST2A GO TO 180 ! ! RESOLVED ADLER-ADLER PARAMETERS ! 70 CALL CANT(ITAPE,C1,C2,LI,L2,NT,NX,MAT,MF,MT,C) K4 = 1 K5 = 1 DO 80 III=1,NLS CALL CONT(ITAPE,C1,C2,L(III),L2,NJS,N2,MAT,MF,MT) NJSA(III) = NJS DO JJJ=1,NJS CALL CANT(ITAPE,AJ(K5),C2,L1,L2,NT,NRS(K5),MAT,MF,MT,RES(K4)) K5 = K5 + 1 K4 = K4 + NT END DO 80 CONTINUE CALL LIST2A GO TO 180 ! ! HYBRID R-FUNCTION ! 85 CALL CONT(ITAPE,C1,C2,NGRE,NFRE,NIRE,NCRE,MAT,MF,MT) NCOMCH = NIRE + NCRE CALL CONT(ITAPE,C1,C2,LRX(1),LRX(2),LRX(3),LRX(4),MAT,MF,MT) CALL CANT(ITAPE,C1,C2,L1,L2,N1,N2,MAT,MF,MT,QX) IF(NCOMCH.GT.0) THEN WRITE(SOUT,87) NCOMCH 87 FORMAT(49X,I1,' Competing Reaction Channels') IF(OUTPUT.NE.0) WRITE(OUTPUT,87) NCOMCH DO 90 III=1,NCOMCH WRITE(SOUT,88) LRX(III),QX(III) 88 FORMAT(52X,'Reaction = ',I3,' Q = ',1PE11.4) IF(OUTPUT.NE.0) WRITE(OUTPUT,88) LRX(III),QX(III) 90 CONTINUE END IF WRITE(SOUT,95) 95 FORMAT( & & /53X,'Angular Channel Spin Resonances'/ & & 53X,'Momentum Spin '/ & & 53X,' (L) (AS) (AJ) (NRS)'/ & & 53X,'-------- ------- ---- ----------') CALL LIST2B(NCOMCH,NCRE) GO TO 180 ! ! RESONANCES ARE UNRESOLVED. ! 100 IF(LRF.EQ.2) GO TO 160 IF(LFW.EQ.0) GO TO 130 ! ! ISOTOPE IS FISSILE ! CALL CANT(ITAPE,SPI,AP,L1,L2,NEL,NLS,MAT,MF,MT,ES) CALL LIST2H(J) NE(1)=NEL DO 120 I3=1,NLS III = I3 CALL CONT(ITAPE,C1,C2,L(III),L2,NJS,N2,MAT,MF,MT) K6=1 DO JJJ=1,NJS CALL CANT(ITAPE,C1,C2,L1,MUF(JJJ),NEPL6,N2,MAT,MF,MT,RES(K6)) K6=K6+NEPL6 END DO CALL LIST2C(III) 120 CONTINUE GO TO 180 ! ! ISOTOPE IS NON-FISSILE ! 130 CALL CONT(ITAPE,SPI,AP,L1,L2,NLS,N2,MAT,MF,MT) CALL LIST2H(J) DO 150 I3=1,NLS III = I3 CALL CANT(ITAPE,C1,C2,L(III),L2,NJS6X,NJS,MAT,MF,MT,RES) CALL LIST2C(III) 150 CONTINUE GO TO 180 ! ! ALL ENERGY DEPENDENT PARAMETERS ! 160 CALL CONT(ITAPE,SPI,AP,L1,L2,NLS,N2,MAT,MF,MT) CALL LIST2H(J) DO 170 I3=1,NLS III = I3 CALL CONT(ITAPE,C1,C2,L(III),L2,NJS,N2,MAT,MF,MT) K6=1 DO JJJ=1,NJS CALL CANT(ITAPE,AJL(JJJ),C2,JNT(JJJ),L2,NEL6X,NE(JJJ),MAT,MF, & & MT,RES(K6)) K6=K6+NEL6X END DO CALL LIST2C(III) 170 CONTINUE ! ! END OF LOOP ON ENERGY REGIONS ! 180 CONTINUE ! ! END OF LOOP ON ISOTOPES ! 200 CONTINUE ! ! SKIP TO THE END OF THE FILE ! CALL SKPFIL(ITAPE) ! RETURN END ! !*********************************************************************** ! SUBROUTINE LIST2H(J) ! ! ROUTINE TO LIST RESONANCE PARAMETER HEADINGS ! COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR COMMON ZARI,ABN,LFW,NER,EL,EH,LRU,LRF,SPI,AP,NLS,NJS,QX(5),LRX(5),& & L(5),NJSA(5),AJ(20),NRS(20),JNT(20),AJL(6),MUF(6),NE(6),ES(250),& & RES(47728),NRO,NBT(200),INT(200),NR,X(1000),Y(1000),NP,C(18),NX,& & DUM(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT ! CHARACTER(LEN=24) ZABCD CHARACTER(LEN=48) RESOP(8) CHARACTER(LEN=24) HEAD CHARACTER(LEN=24) UNIT ! DATA RESOP/'Resolved Resonance Parameters NOT GIVEN ', & & 'Resolved Single-Level BREIT-WIGNER Parameters', & & 'Resolved Multi-Level BREIT-WIGNER Parameters', & & 'Resolved Multi-Level R-MATRIX Parameters', & & 'Resolved Multi-Level ADLER-ADLER Parameters', & & 'Resolved Multi-Level REICH-MOORE Parameters', & & 'Resolved HYBRID R-FUNCTION Parameters', & & 'Unresolved Single-Level BREIT-WIGNER Parameters'/ ! DATA HEAD/' Energy Length '/ DATA UNIT/' eV 10**-12 cm '/ ! ! OUTPUT PAGE HEADER ! CALL TOPAGE ! ! OUTPUT ISOTOPE ID TEXT ! CALL ZAID(ZARI,ZABCD,IERR) IF(OUTPUT.GT.0) WRITE(OUTPUT,5) ZABCD,ABN 5 FORMAT(' Isotope----------------------',1X,A24/ & & ' Fractional abundance---------',1PE11.4) ! ! OUTPUT REGION TYPE AND RANGE TO SUMMARY ! IF(LRU.LT.2) THEN WRITE(SOUT,8) EL,EH 8 FORMAT(/46X,'RESOLVED RESONANCE REGION from',1PE11.4,' to', & & 1PE11.4,' eV') ELSE WRITE(SOUT,10) EL,EH 10 FORMAT(/46X,'UNRESOLVED RESONANCE REGION from',1PE11.4,' to', & & 1PE11.4,' eV') END IF WRITE(SOUT,15) SPI 15 FORMAT(49X,'Nuclear Spin is',1PE11.4) ! ! OUTPUT PARAMETER TYPE TO SUMMARY ! IF(LRU.LT.2) THEN LRF1 = LRF + 1 IF(LRF.EQ.3.AND.NFOR.EQ.5) LRF1 = 6 ISTAR = 10 ELSE LRF1 = 8 ISTAR = 12 END IF WRITE(SOUT,16) RESOP(LRF1)(ISTAR:) 16 FORMAT(/49X,A) ! ! OUTPUT PARAMETER OPTION ! IF(OUTPUT.LE.0) GO TO 25 WRITE(OUTPUT,20) NER,J,RESOP(LRF1),EL,EH,SPI 20 FORMAT(' Number of energy ranges------',I11// & & ' Energy range number----------',I11,3X,A/ & & ' Lower energy limit (eV)------',1PE11.4/ & & ' Upper energy limit (eV)------',1PE11.4/ & & ' Nuclear spin-----------------',1PE11.4) IF(LRU.NE.0) WRITE(OUTPUT,22) NLS 22 FORMAT(' Number of L states-----------',I11) ! ! OUTPUT IF CONSTANT SCATTERING LENGTH ! 25 IF(LRF.GT.4) GO TO 50 IF(NRO.GT.0) GO TO 30 IF(LRF.EQ.3) GO TO 50 IF(OUTPUT.GT.0) WRITE(OUTPUT,26) AP 26 FORMAT(' Scattering length (A)--------',1PE11.4) WRITE(SOUT,27) 27 FORMAT(49X,'Energy Independent Scattering Length') GO TO 50 ! ! OUTPUT ENERGY DEPENDENT SCATTERING LENGTH ! 30 CALL INTAB(NBT,INT,NR,1,OUTPUT) IF(OUTPUT.GT.0) WRITE(OUTPUT,35) 35 FORMAT(/' Energy Dependent Scattering Length') CALL WRTAB1(OUTPUT,HEAD,UNIT,X,Y,NP) WRITE(SOUT,40) NP,NR 40 FORMAT(49X,'Energy Dependent Scattering Length specified at'/ & & 52X,I3,' ENERGY POINTS with ',I4,' INTERPOLATION REGIONS') ! ! OUTPUT OF HEADING FOR RESONANCE SUMMARY TABLE ! 50 IF(LRU.EQ.1) THEN IF(LRF.EQ.6) GO TO 100 WRITE(SOUT,75) 75 FORMAT( & & /53X,'Angular Spin Resonances'/ & & 53X,'Momentum'/ & & 53X,' (L) (AJ) (NRS)'/ & & 53X,'-------- ---- ----------') ELSE IF(LRU.EQ.2) THEN WRITE(SOUT,85) 85 FORMAT( & & /53X,'Angular Spin Energy Number Interp.'/ & & 53X,'Momentum Dependence Energies Scheme '/ & & 53X,' (L) (AJ) (NE) (INT) '/ & & 53X,'-------- ---- -------- ------ -------') END IF ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE LIST2A ! ! ROUTINE TO LIST RESOLVED RESONANCE PARAMETERS EXCEPT HYBRID ! R-FUNCTION ! COMMON ZARI,ABN,LFW,NER,EL,EH,LRU,LRF,SPI,AP,NLS,NJS,QX(5),LRX(5),& & L(5),NJSA(5),AJ(20),NRS(20),JNT(20),AJL(6),MUF(6),NE(6),ES(250),& & RES(47728),NRO,NBT(200),INT(200),NR,X(1000),Y(1000),NP,C(18),NX,& & DUM(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT ! INTEGER NOFJ(20) ! CHARACTER(LEN=10) CTYPE(3) DATA CTYPE/'TOTAL','FISSION','CAPTURE'/ ! ! OUTPUT RESONANCE PARAMETERS EXCEPT FOR ADLER-ADLER ! IF(LRF.EQ.4) GO TO 110 K6 = 0 DO 100 III=1,NLS FL = FLOAT(L(III)) SPMIN = ABS(ABS(SPI-FL) - 0.5) DO JJJ=1,20 NOFJ(JJJ) = 0 END DO IF(OUTPUT.GT.0.AND.NLS.GT.1) WRITE(OUTPUT,50) 50 FORMAT('1') IF(OUTPUT.GT.0) WRITE(OUTPUT,60) L(III),NRS(III) 60 FORMAT(///' L value----------------------',I11/ & & ' Number of resonances---------',I11) IF(OUTPUT.GT.0.AND.LRX(III).EQ.1) WRITE(OUTPUT,65) QX(III) 65 FORMAT( ' Competitive width Q-value----',1PE11.4) KADD = 6 IF(OUTPUT.EQ.0) GO TO 75 IF(LRF.NE.3) THEN WRITE(OUTPUT,70) 70 FORMAT(/44X,' Resonance Widths (eV)'/' Index Energy (eV) ',& & 'J value Total Neutron Radiation ', & & 'Fission'/) ELSE WRITE(OUTPUT,74) 74 FORMAT(/44X,' Resonance Widths (eV)'/' Index Energy (eV) ',& & 'J value Neutron Radiation Fission-1 ', & & 'Fission-2'/) END IF 75 K5=NRS(III) DO 90 KN=1,K5 K6L = K6 + 1 K6 = K6 + KADD IF(OUTPUT.GT.0) WRITE(OUTPUT,80) KN,(RES(K4),K4=K6L,K6) 80 FORMAT(I5,2X,7(1PE11.4,2X)) JJJ = RES(K6L+1) - SPMIN + 1.001 NOFJ(JJJ) = NOFJ(JJJ) + 1 90 CONTINUE SPMAX = SPI + FL + 0.5 AJJ = SPMIN DO 97 JJJ=1,20 IF(JJJ.EQ.1) WRITE(SOUT,93) FL,AJJ,NOFJ(JJJ) 93 FORMAT(53X,F5.1,F12.1,I13) IF(JJJ.GT.1) WRITE(SOUT,95) AJJ,NOFJ(JJJ) 95 FORMAT(58X,F12.1,I13) AJJ = AJJ + 1. IF(AJJ.GT.SPMAX) GO TO 100 97 CONTINUE 100 CONTINUE GO TO 1000 ! ! PARAMETER OUTPUT FOR ADLER-ADLER ! 110 IF(OUTPUT.GT.0) WRITE(OUTPUT,120) 120 FORMAT(//10X,'ADLER-ADLER Background Cross Section'/) DO 130 K=1,NX JL = 6*(K-1) + 1 IF(OUTPUT.GT.0) WRITE(OUTPUT,125) CTYPE(K),(C(JJJ),JJJ=JL,JL+5) 125 FORMAT(1X,A10,'(C/SQRT(E))*(',1PE11.4,' + ',1PE11.4,'/E + ', & & 1PE11.4,'/E**2 + ',1PE11.4,'/E**3 + ',1PE11.4,'*E + ', & & 1PE11.4,'*E**2)') 130 CONTINUE K6 = 0 K5 = 1 DO 180 III=1,NLS NJS = NJSA(III) FL = FLOAT(L(III)) DO JJJ=1,NLS IF(OUTPUT.GT.0.AND.(NLS.GT.1.OR.NJSA(1).GT.1)) WRITE(OUTPUT,50) IF(OUTPUT.GT.0) WRITE(OUTPUT,135) L(III),AJ(K5),NRS(K5) 135 FORMAT(///' L value----------------------',I11/ & & ' J value----------------------',1PE11.4/ & & ' Number of resonances---------',I11) IF(OUTPUT.GT.0) WRITE(OUTPUT,150) 150 FORMAT(/44X,' RESONANCE PARAMETERS'/' Index MU(eV) ', & & ' NU(eV) G(T) H(T) G(F) ', & & ' H(F) G(C) H(C)'/) K4=NRS(K5) DO KN=1,K4 IF(OUTPUT.GT.0) WRITE(OUTPUT,175) KN,(RES(K3),K3=K6+1,K6+4), & & RES(K6+7),RES(K6+8),RES(K6+11),RES(K6+12) 175 FORMAT(I5,2X,8(1PE11.4,2X)) K6=K6+12 END DO IF(JJJ.EQ.1) WRITE(SOUT,93) FL,AJ(K5),NRS(K5) IF(JJJ.GT.1) WRITE(SOUT,95) AJ(K5),NRS(K5) K5 = K5 + 1 END DO 180 CONTINUE ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE LIST2B(NCOMCH,NCRE) ! ! ROUTINE TO LIST HYBRID R-FUNCTION DATA ! COMMON ZARI,ABN,LFW,NER,EL,EH,LRU,LRF,SPI,AP,NLS,NJS,QX(5),LRX(5),& & L(5),NJSA(5),DU(20),NRS(20),JNT(20),AJL(6),MUF(6),NE(6),ES(250),& & RES(47728),NRO,NBT(200),INT(200),NR,X(1000),Y(1000),NP,C(18),NX,& & DUM(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT ! CHARACTER(LEN=24) HEAD CHARACTER(LEN=24) UNIT CHARACTER(LEN=6) ORDS(4) ! DATA HEAD/' Energy Data '/ DATA UNIT/' eV '/ DATA ORDS/'First ','Second','Third ','Fourth'/ ! ! PROCESS CHARGED PARTICLE PENETRABILITIES ! IF(NCRE.GT.0) THEN DO 25 NCR=1,NCRE DO 15 LIL=1,4 CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) IF(OUTPUT.EQ.0) GO TO 25 WRITE(OUTPUT,10) ORDS(NCR),LIL-1 10 FORMAT(/38X,'Charged Particle Penetrability for ',A6,' CP ', & & 'Channel, L=',I1/38X,52('-')/) CALL INTAB(NBT,INT,NR,1,OUTPUT) CALL WRTAB1(OUTPUT,HEAD,UNIT,X,Y,NP) 15 CONTINUE 25 CONTINUE END IF ! ! PROCESS ALL L-VALUES ! DO 95 NL=1,NLS CALL CONT(ITAPE,C1,C2,LL,L2,NSS,N2,MAT,MF,MT) FLL = LL ! ! OUTPUT CURRENT L AND NUMBER OF S VALUES ! IF(OUTPUT.GT.0) WRITE(OUTPUT,5) LL,NSS 5 FORMAT(///' L value----------------------',I11/ & & ' Number of S States-----------',I11) ! ! PROCESS ALL CHANNEL SPIN STATES ! DO NS=1,NSS CALL CONT(ITAPE,AS,C2,L1,L2,NJS,N2,MAT,MF,MT) ! ! OUTPUT CURRENT L AND S AND NUMBER OF J VALUES ! IF(OUTPUT.GT.0) WRITE(OUTPUT,30) LL,AS,NJS 30 FORMAT(///21X,'L value----------------------',I11/ & & 21X,'S value----------------------',F11.1/ & & 21X,'Number of J States-----------',I11) ! ! PROCESS ALL TOTAL SPIN STATES ! DO 90 NJ=1,NJS CALL CANT(ITAPE,AJ,C2,LBK,LPS,N1,NLSJ,MAT,MF,MT,RES) IF(OUTPUT.EQ.0) GO TO 55 IF(NCOMCH.NE.0) THEN WRITE(OUTPUT,35) AJ,(LRX(III),III=1,NCOMCH) 35 FORMAT(/43X,'Resonance Parameters for J = ',F4.1,' in (eV)'/ & & 43X,41('-')/' Index Energy (eV) ', & & 'Neutron ','Capture ','Fission ', & & 4('MT = ',I3,' (L-out) ')) ELSE WRITE(OUTPUT,36) AJ 36 FORMAT(/43X,'Resonance Parameters for J = ',F4.1,' in (eV)'/ & & 43X,41('-')/' Index Energy (eV) ', & & 'Neutron ','Capture ','Fission ') END IF WRITE(OUTPUT,37) 37 FORMAT(' ') II = 2 !*****OUTPUT EACH RESONANCE DO 50 NN=1,NLSJ IF(NCOMCH.NE.0) THEN IL = II + 3 IU = II + NCOMCH + 2 WRITE(OUTPUT,40) NN,RES(II-1),RES(II),RES(II+1),RES(II+2), & & (RES(III),RES(III+4),III=IL,IU) 40 FORMAT(I5,2X,4(1PE11.4,2X),4(1PE11.4,' (',0PF2.0,')',2X)) ELSE WRITE(OUTPUT,42) NN,RES(II-1),RES(II),RES(II+1),RES(II+2) 42 FORMAT(I5,2X,4(1PE11.4,2X)) END IF II = II + 12 50 CONTINUE 55 IF(NJ.NE.1) THEN WRITE(SOUT,60) AJ,NLSJ 60 FORMAT(70X,F11.1,I13) ELSE IF(NS.NE.1) THEN WRITE(SOUT,62) AS,AJ,NLSJ 62 FORMAT(58X,F12.1,F11.1,I13) ELSE WRITE(SOUT,65) FLL,AS,AJ,NLSJ 65 FORMAT(53X,F5.1,F12.1,F11.1,I13) END IF END IF !*****BACKGROUND COMPONENT IF(LBK.NE.0) THEN CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) IF(OUTPUT.EQ.0) GO TO 72 WRITE(OUTPUT,70) 70 FORMAT(/38X,'Real Part of R-Function Background for this ', & & 'Channel'/38X,52('-')/) CALL INTAB(NBT,INT,NR,1,OUTPUT) CALL WRTAB1(OUTPUT,HEAD,UNIT,X,Y,NP) 72 CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) IF(OUTPUT.EQ.0) GO TO 78 WRITE(OUTPUT,75) 75 FORMAT(/35X,'Imaginary Part of R-Function Background for ', & & 'this Channel'/35X,52('-')/) CALL INTAB(NBT,INT,NR,1,OUTPUT) CALL WRTAB1(OUTPUT,HEAD,UNIT,X,Y,NP) 78 CONTINUE END IF !*****OPTICAL MODEL PHASE SHIFT IF(LPS.NE.0) THEN CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) IF(OUTPUT.EQ.0) GO TO 82 WRITE(OUTPUT,80) 80 FORMAT(/34X,'Real Part of the Optical Model Phase Shift ', & & 'for this Channel'/34X,60('-')/) CALL INTAB(NBT,INT,NR,1,OUTPUT) CALL WRTAB1(OUTPUT,HEAD,UNIT,X,Y,NP) 82 CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) IF(OUTPUT.EQ.0) GO TO 88 WRITE(OUTPUT,85) 85 FORMAT(/31X,'Imaginary Part of the Optical Model Phase Shift ',& & 'for this Channel'/31X,66('-')/) CALL INTAB(NBT,INT,NR,1,OUTPUT) CALL WRTAB1(OUTPUT,HEAD,UNIT,X,Y,NP) 88 CONTINUE END IF 90 CONTINUE END DO 95 CONTINUE ! RETURN END ! !*********************************************************************** ! SUBROUTINE LIST2C(III) ! ! ROUTINE TO LIST UNRESOLVED RESONANCE PARAMETERS ! COMMON ZARI,ABN,LFW,NER,EL,EH,LRU,LRF,SPI,AP,NLS,NJS,QX(5),LRX(5),& & L(5),NJSA(5),AJ(20),NRS(20),JNT(20),AJL(6),MUF(6),NE(6),ES(250),& & RES(47728),NRO,NBT(200),INT(200),NR,X(1000),Y(1000),NP,C(18),NX,& & DUM(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT ! CHARACTER(LEN=7) EDEP ! CHARACTER(LEN=8) ILAW(5) DATA ILAW/'CONSTANT','LIN LIN ','LIN LOG ','LOG LIN ','LOG LOG '/ ! ! OUTPUT CURRENT L AND NUMBER OF J VALUES ! IF(OUTPUT.GT.0) WRITE(OUTPUT,45) L(III),NJS 45 FORMAT(///' L value----------------------',I11/ & & ' Number of J States-----------',I11) FL = FLOAT(L(III)) ! ! BRANCH ON REPRESENTATION OPTION ! IF(LRF.EQ.2) GO TO 200 ! ! ONLY FISSION WIDTHS ENERGY DEPENDENT ! IF(OUTPUT.GT.0) WRITE(OUTPUT,50) 50 FORMAT(/41X,'Average Resonance Widths (eV)'/41X,29('-')) K6=1 NEL = 0 EDEP = ' NONE' IF(LFW.EQ.0) GO TO 60 EDEP = 'FISSION' NEL = NE(1) 60 NEPL6 = NEL + 6 NEL=NE(1) DO 150 K=1,NJS IF(OUTPUT.GT.0.AND.(K.EQ.1.OR.LFW.EQ.1)) WRITE(OUTPUT,70) 70 FORMAT (' Level Spacing J-value Deg of Freedom ', & & 'Neutron Radiation'/) KH=K6+4 IF(OUTPUT.GT.0) WRITE(OUTPUT,80) (RES(M),M=K6,KH) 80 FORMAT(5(3X,1PE11.4)) ! ! OUTPUT ENERGY DEPENDENT FISSION WIDTH ! IF(LFW.EQ.0) GO TO 125 IF(OUTPUT.GT.0) WRITE(OUTPUT,90) MUF(K) 90 FORMAT(/' Energy Fission Width ', & & 'Degrees of Freedom used =',I5) KL=K6+6 DO N=1,NEL IF(OUTPUT.GT.0) WRITE(OUTPUT,80) ES(N),RES(KL) KL=KL+1 END DO 125 IF(K.EQ.1) WRITE(SOUT,130) FL,RES(K6+1),EDEP,NEL,ILAW(2) 130 FORMAT(53X,F6.1,F11.1,6X,A7,I11,8X,A8) IF(K.GT.1) WRITE(SOUT,140) RES(K6+1),EDEP,NEL,ILAW(2) 140 FORMAT(59X,F11.1,6X,A7,I11,8X,A8) K6=K6+NEPL6 150 END DO GO TO 1000 ! ! ALL PARAMETERS ENERGY DEPENDENT ! 200 K6=1 EDEP = ' ALL' DO 250 K=1,NJS NEL6X=6*NE(K)+6 KL=K6+2 KH=K6+5 IF(OUTPUT.GT.0) WRITE(OUTPUT,210) 210 FORMAT(///37X,'Degrees of Freedom used in the Width Distribution'/& & 37X,49('-')/13X,'J-value Interp. Competitive ', & & 'Neutron Radiation Fission') INTT = JNT(K) IF(OUTPUT.GT.0) WRITE(OUTPUT,220) AJL(K),ILAW(INTT), & & (RES(M),M=KL,KH) 220 FORMAT(10X,1PE11.4,4X,A8,2X,4(1PE11.4,2X)) IF(OUTPUT.GT.0) WRITE(OUTPUT,230) 230 FORMAT(/44X,'Average RESONANCE WIDTHS (eV)'/44X,29('-')/ & & ' Index Energy(eV) Level Spacing Competitive ', & & 'Neutron Radiation Fission') NEL=NE(K) DO 240 N=1,NEL KL=KH+1 KH=KL+5 IF(OUTPUT.GT.0) WRITE(OUTPUT,235) N,(RES(M),M=KL,KH) 235 FORMAT(I5,4X,6(1PE11.4,2X)) 240 CONTINUE INTT = JNT(K) IF(K.EQ.1) WRITE(SOUT,130) FL,AJL(K),EDEP,NE(K),ILAW(INTT) IF(K.GT.1) WRITE(SOUT,140) AJL(K),EDEP,NE(K),ILAW(INTT) K6=K6+NEL6X 250 END DO ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE3 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 3 ! COMMON DUM(110),NBT(200),INT(200),X(50000),Y(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI ! CHARACTER(LEN=24) UNIT(2) CHARACTER(LEN=24) HEAD(2) CHARACTER(LEN=21) TITLE(3) ! DATA UNIT/' Energy Sigma ', & & ' Energy Data '/ DATA HEAD/' eV Barns ', & & ' eV '/ DATA TITLE/'CROSS SECTIONS ', & & 'SCATTERING PARAMETERS', & & 'ENERGY DEPOSIT '/ ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,0,ZAI) ! ! OUTPUT FILE HEADING TO SUMMARY ! CALL FILEHD(MFI) ! ! SET SECTION ID INFORMATION ! 10 CALL HEADIN(0,0,MTI,-1.0) ! ! WRITE PAGE LABEL ! CALL TOPAGE ! ! READ IN DATA FOR THE SECTION ! CALL CANT1(ITAPE,QM,QI,L1,LR,NR,NP,MAT,MF,MT,NBT,INT,X,Y) ! ! OUTPUT Q VALUE(S) ! IF(NFOR.GT.5.OR.LR.NE.0) GO TO 20 IF(OUTPUT.GT.0.AND.QI.NE.0.0) WRITE(OUTPUT,15) QI 15 FORMAT(/' Reaction Q-value ',1PE11.4,' eV') GO TO 30 20 IF(OUTPUT.GT.0.AND.QM.NE.0.0) WRITE(OUTPUT,15) QM IF(OUTPUT.GT.0.AND.QI.NE.0.0) WRITE(OUTPUT,25) QI 25 FORMAT(/' Intermediate State Q-value ',1PE11.4,' eV') ! ! OUTPUT SECTION INFO TO SUMMARY ! 30 CALL GETLIM(XMIN,XMAX,X,Y,NP) IF(NFOR.LT.6) THEN WRITE(SOUT,35) MTI,MTBCD,QI,NP,XMIN,XMAX,NR 35 FORMAT(/I6,3X,A30,14X,1PE11.4,3X,I4,2X,1PE11.4,1X,1PE11.4, & & 4X,I3) ELSE WRITE(SOUT,37) MTI,MTBCD,QM,QI,NP,XMIN,XMAX,NR 37 FORMAT(/I6,3X,A30,14X,2(1PE11.4,3X),I4,2X,1PE11.4,1X, & & 1PE11.4,4X,I3) END IF ! ! OUTPUT INTERPOLATION TABLE ! CALL INTAB(NBT,INT,NR,1,OUTPUT) ! ! OUTPUT DATA ! IHEAD = 1 IF(MTI.GT.250.AND.MTI.LE.300) IHEAD = 2 IF(MTI.GT.300.AND.MTI.LE.450) IHEAD = 3 IF(OUTPUT.GT.0) WRITE(OUTPUT,50) TITLE(IHEAD) 50 FORMAT(/1X,A21) IHEAD = MIN0(IHEAD,2) CALL WRTAB1(OUTPUT,HEAD(IHEAD),UNIT(IHEAD),X,Y,NP) ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) ! ! SEE IF ANOTHER SECTION IN FILE THREE ! CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE4 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 4 ! COMMON DUM(104),E,NP,NL,LCT,EG,ES,NBT(200),INT(200),P(101), & & FMU(101),PL(81,64),FL(64),TMATRX(4225),DUM1(40264),DUM2(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/HEADI/ZAI,AWRI,LVT,LTT,N1I,N2I,MATI,MFI,MTI ! PARAMETER (NANG=81,NCOF=64) INTEGER JJJ(10) ! CHARACTER(LEN=4) LOCM(2) CHARACTER(LEN=21) LCMT(2) CHARACTER(LEN=14) LABCMS(2) CHARACTER(LEN=9) DREP(3) ! DATA LOCM/'LAB ','C.M.'/ DATA LCMT/'LAB TO CENTER OF MASS', & & 'CENTER OF MASS TO LAB'/ DATA LABCMS/' LABORATORY ', & & 'CENTER OF MASS'/ DATA DREP/'LEGENDRE ','TABULATED','MIXED'/ ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,0,ZAI) ! ! OUTPUT FILE HEADING TO SUMMARY ! CALL FILEHD(MFI) ! ! SET SECTION ID INFORMATION ! 10 CALL HEADIN(0,0,MTI,-1.0) ! ! WRITE PAGE LABEL ! CALL TOPAGE ! ! PROCESS TRANSFORMATION MATRIX IF IT EXISTS ! IF(LVT.EQ.0)GO TO 75 CALL CANT(ITAPE,C1,C2,LI,LCT,NK,NM,MAT,MF,MT,TMATRX) LCT2 = MOD(LCT,2) + 1 IF(OUTPUT.GT.0) WRITE(OUTPUT,20) LCMT(LCT),LOCM(LCT2),LOCM(LCT) 20 FORMAT(/' Transformation Matrix from ',A21,' System'/ & & ' F(E,L,',A4,')=(sum over M) U(L,M)*F(E,M,',A4,')') NMM=NM+1 NLL=NK/NMM KK=0 DO 50 I=1,NMM,10 II = MIN0(I+9,NMM) JJ=0 DO J=I,II JJ=JJ+1 JJJ(JJ)=J-1 END DO IF(OUTPUT.GT.0) WRITE(OUTPUT,40) (JJJ(K),K=1,JJ) 40 FORMAT(' L/M ',I6,9I12) DO L=1,NLL K=L-1 KK=L+(I-1)*NLL KKK = MIN0(KK+9*NLL,NK) IF(KKK.GT.NK) KKK=NK IF(OUTPUT.GT.0) WRITE(OUTPUT,45) K,(TMATRX(JL),JL=KK,KKK,NLL) 45 FORMAT(I4,2X,10(1PE12.4)) END DO 50 CONTINUE GO TO 100 ! ! NO TRANSFORMATION MATRIX ! 75 CALL CONT(ITAPE,C1,C2,LI,LCT,N1,N2,MAT,MF,MT) ! ! PROCESS THE DISTRIBUTIONS ! 100 IF(LI.EQ.1) GO TO 200 ! ! LIST INTERPOLATION LAW BETWEEN ENERGIES ! CALL CANT2(ITAPE,C1,C2,L1,L2,NR,NE,MAT,MF,MT,NBT,INT) CALL INTAB(NBT,INT,NR,1,OUTPUT) NMIN = 100000 NMAX = 0 NRR = NR ! ! DATA IS IN THE FORM OF LEGENDRE COEFFICIENTS ! IF(LTT.EQ.2) GO TO 150 ! ! GENERATE TABLES OF LEGENDRE POLYNOMIALS ! CALL LEGEND(PL,NCOF,NANG,1.0,-1.0) DO J=1,NANG P(J) = PL(J,1) END DO ! ! SET UP LOOP OVER ENERGIES ! NP = NANG DO 110 I=1,NE ! ! READ TABLE OF LEGENDRE COEFFICIENTS ! CALL CANT(ITAPE,C1,E,L1,L2,NL,N2,MAT,MF,MT,FL) IF(I.EQ.1) ELO = E IF(I.EQ.NE) EHI = E NMIN = MIN0(NMIN,NL) NMAX = MAX0(NMAX,NL) ! ! RECONSTRUCT AND LIST ANGULAR DISTRIBUTION ! CALL ANGLAR(FMU,FL,PL,NL,NCOF,NANG) CALL TOPAGE CALL LIST4 110 CONTINUE ! ! CHECK FOR BOTH LEGENDRE AND TABULAR ! IF(LTT.EQ.1) GO TO 180 CALL CANT2(ITAPE,C1,C2,L1,L2,NR,NE,MAT,MF,MT,NBT,INT) CALL INTAB(NBT,INT,NR,1,OUTPUT) NMIN = 100000 NMAX = 0 NRR = NR ! ! DATA IS IN TABULAR FORM ! 150 CONTINUE ! ! SET UP LOOP OVER ENERGIES ! DO 160 I=1,NE ! ! READ TABULATED ANGULAR DISTRIBUTION ! CALL CANT1(ITAPE,C1,E,L2,L2,NR,NP,MAT,MF,MT,NBT,INT,P,FMU) IF(I.EQ.1) ELO = E IF(I.EQ.NE) EHI = E NMIN = MIN0(NMIN,NP) NMAX = MAX0(NMAX,NP) ! ! LIST INTERPOLATION LAW AT TOP OF NEW PAGE ! CALL TOPAGE CALL INTAB(NBT,INT,NR,2,OUTPUT) ! ! LIST TABULAR ANGULAR DISTRIBUTION ! CALL LIST4 160 CONTINUE ! ! OUTPUT TO SUMMARY FILE ! 180 WRITE(SOUT,190) MTI,MTBCD,LOCM(LCT),NE,ELO,EHI,NRR, & & DREP(LTT),NMIN,NMAX 190 FORMAT(/I6,3X,A30,3X,2X,A4,4X,I4,3X,1PE11.4,1X,1PE11.4,3X, & & I3,4X,A9,3X,I3,5X,I3) GO TO 250 ! ! ALL DISTRIBUTIONS ARE ISOTROPIC ! 200 IF(OUTPUT.GT.0) WRITE(OUTPUT,210) LABCMS(LCT) 210 FORMAT(/' All Angular Distributions are ISOTROPIC in the ', & & A14,' System') WRITE(SOUT,260) MTI,MTBCD,LOCM(LCT) 260 FORMAT(/I6,3X,A30,5X,A4,44X,'ISOTROPIC') ! ! SKIP SEND RECORD ! 250 CALL SKPREC(ITAPE,1) ! ! CHECK FOR NEW SECTION OR END OF FILE ! CALL CONT(ITAPE,ZAI,AWRI,LVT,LTT,N1I,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE LIST4 ! ! ROUTINE TO LIST ANGULAR DATA ! COMMON DUM(104),E,NP,NL,LCT,EG,ES,NBT(200),INT(200),P(101), & & FMU(101),PL(81,64),FL(64),TMATRX(4225),DUM1(40264),DUM2(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/HEADI/ZAI,AWRI,LVT,LTT,N1I,N2I,MATI,MFI,MTI ! CHARACTER(LEN=14) LABCMS(2) CHARACTER(LEN=24) HEAD CHARACTER(LEN=24) UNIT ! DATA LABCMS/' LABORATORY ', & & 'CENTER OF MASS'/ DATA HEAD/' MU F(MU) '/ DATA UNIT/' '/ ! ! SCALE ENERGY ! E = E*1.0E-06 ! ! BRANCH ON REPRESENTATION TYPE ! IF(LTT.EQ.1) GO TO 100 ! ! TABULAR DISTRIBUTION ! DO 20 I=1,NP IF(FMU(I).NE.FMU(1)) GO TO 50 20 CONTINUE !*****DISTRIBUTION IS ISOTROPIC IF(OUTPUT.GT.0) WRITE(OUTPUT,30) LABCMS(LCT),E 30 FORMAT(' Tabulated Distribution in the ',A14,' System at', & & 1PE11.4,' MeV is ISOTROPIC') GO TO 1000 ! ! NOT ISOTROPIC SO WRITE OUT APPROPRIATE HEADING ! 50 IF(MFI.EQ.14) GO TO 65 IF(OUTPUT.GT.0) WRITE(OUTPUT,60) LABCMS(LCT),E 60 FORMAT(/' Tabulated Angular Distribution in the ',A14, & & ' System at',1PE11.4,' MeV') GO TO 200 65 IF(OUTPUT.GT.0.AND.EG.EQ.0.0) WRITE(OUTPUT,70) 70 FORMAT(/' Tabulated Angular Distribution at NEUTRON ENERGY', & & 1PE11.4,' MeV, CONTINUOUS SPECTRUM') IF(OUTPUT.GT.0.AND.EG.NE.0.0) WRITE(OUTPUT,75) EG,ES 75 FORMAT(/' Tabulated Angular Distribution at NEUTRON ENERGY', & & 1PE11.4,' MeV, ENERGY',1PE11.4,' MeV, ENERGY STATE', & & 1PE11.4,' MeV') GO TO 200 ! ! LEGENDRE COEFFICIENT EXPANSION ! 100 ISO = 0 IF(NL.LE.0) GO TO 130 DO 120 I=1,NL IF(ABS(FL(I)).NE.0.0)GO TO 150 120 CONTINUE !*****DISTRIBUTION IS ISOTROPIC 130 ISO = 1 IF(OUTPUT.GT.0) WRITE(OUTPUT,140) LABCMS(LCT),E 140 FORMAT(/' Reconstructed Angular Distribution in the ',A14, & & ' System at',1PE11.4,' MeV is ISOTROPIC') GO TO 168 ! ! NOT ISOTROPIC SO WRITE APPROPRIATE HEADING ! 150 IF(MFI.EQ.14) GO TO 160 IF(OUTPUT.GT.0) WRITE(OUTPUT,155) LABCMS(LCT),E 155 FORMAT(/' Reconstructed Angular Distribution in the ',A14, & & ' System at',1PE11.4,' MeV') GO TO 168 160 IF(OUTPUT.GT.0.AND.EG.EQ.0.0) WRITE(OUTPUT,162) 162 FORMAT(/' Reconstructed Angular Distribution at NEUTRON ENERGY', & & 1PE11.4,' MeV, CONTINUOUS SPECTRUM') IF(OUTPUT.GT.0.AND.EG.NE.0.0) WRITE(OUTPUT,165) EG,ES 165 FORMAT(/' Reconstructed Angular Distribution at NEUTRON ENERGY', & & 1PE11.4,' MeV, ENERGY',1PE11.4,' MeV, ENERGY STATE', & & 1PE11.4,' MeV') ! ! WRITE LEGENDRE COEFFICIENTS ! 168 NNL=NL+1 IF(OUTPUT.GT.0) WRITE(OUTPUT,170) NNL 170 FORMAT(I5,' LEGENDRE COEFFICIENTS were used in the ', & & 'reconstruction') IF(OUTPUT.GT.0) WRITE(OUTPUT,175)(I,FL(I),I=1,NL) 175 FORMAT((8(I3,1PE11.4))) IF(ISO.EQ.1) GO TO 1000 IF(OUTPUT.GT.0) WRITE(OUTPUT,180) 180 FORMAT(/' F(MU)=(sum over L) (0.5*(2L+1)*F(L,E)*P(L,MU))') ! ! WRITE ANGULAR DISTRIBUTION ! 200 CALL WRTAB1(OUTPUT,HEAD,UNIT,P,FMU,NP) ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE5 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 5 DATA ! COMMON DUM(107),NR,NP,U,NBT(200),INT(200),X(50000),Y(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/HEADI/ZAI,AWRI,L1I,L2I,NK,N2I,MATI,MFI,MTI COMMON/SFIVE/ELO,EHI,NE,NF ! PARAMETER (NLAWS=6) CHARACTER(LEN=15) LAWS(NLAWS) INTEGER ILAW(NLAWS) ! DATA LAWS/'TABULATED(1) ','GEN.EVAP.(5) ', & & 'MAXWELLIAN(7) ','EVAPORATION(9) ', & & 'WATT(11) ','MADLAND-NIX(12)'/ DATA ILAW/1,5,7,9,11,12/ ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,0,ZAI) ! ! OUTPUT FILE HEADING TO SUMMARY ! CALL FILEHD(MFI) ! ! SET SECTION IDENTIFICATION INFORMATION ! 10 CALL HEADIN(0,0,MTI,-1.0) ! ! PROCESS EACH PARTIAL ENERGY DISTRIBUTION ! DO 150 I=1,NK CALL CANT1(ITAPE,U,C2,L1,LF,NR,NP,MAT,MF,MT,NBT,INT,X,Y) NPE = NP ! ! CHECK FOR VALID LAW ! DO 20 J=1,NLAWS IF(LF.EQ.ILAW(J)) GO TO 30 20 CONTINUE GO TO 200 ! ! TABULAR FUNCTION ! 30 IF(LF.NE.1) GO TO 50 CALL LIST5A GO TO 100 ! ! GENERAL AND SIMPLE EVAPORATION, MAXWELLIAN, WATT AND MADLAND-NIX ! REPRESENTATION ! 50 CALL LIST5B(LF) ! ! OUTPUT TO SUMMARY FILE ! 100 IF(I.EQ.1) THEN WRITE(SOUT,110) MTI,MTBCD,LAWS(J),NPE,ELO,EHI,NR,NE,NF,U 110 FORMAT(/I6,3X,A30,3X,A15,I6,3X,1PE11.4,1X,1PE11.4,3X,I3,1X, & & 2I6,3X,1PE11.4) ELSE WRITE(SOUT,120) LAWS(J),NPE,ELO,EHI,NR,NE,NF,U 120 FORMAT(42X,A15,I6,3X,1PE11.4,1X,1PE11.4,3X,I3,1X,2I6,3X, & & 1PE11.4) END IF ! 150 CONTINUE ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) GO TO 250 ! ! INVALID LAW, SKIP REST OF SECTION ! 200 IF(OUTPUT.GT.0) WRITE(OUTPUT,210) LF 210 FORMAT(//5X,'LF = ',I2,' IS ILLEGAL. REST OF SECTION IS SKIPPED') CALL SKPSEC(ITAPE) ! ! CHECK FOR NEW SECTION OR END OF FILE ! 250 CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,NK,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE LIST5A ! ! PROCESS AND LIST A FILE FIVE TABULAR REPRESENTATION ! COMMON DUM(107),NR,NP,U,NBT(200),INT(200),X(50000),Y(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/SFIVE/ELO,EHI,NE,NF ! CHARACTER(LEN=24) HEAD(2) CHARACTER(LEN=24) UNIT ! DATA HEAD/' Energy P(E) ', & & ' E'' G(E'') '/ DATA UNIT/' eV '/ ! ! OUTPUT PAGE HEADER ! CALL TOPAGE IF(OUTPUT.GT.0) WRITE(OUTPUT,10) 10 FORMAT(//' TABULATED SPECTRUM') ! ! OUTPUT DISTRIBUTION PROBABILITY WITH INTERPOLATION SCHEME ! CALL INTAB(NBT,INT,NR,1,OUTPUT) CALL WRTAB1(OUTPUT,HEAD(1),UNIT,X,Y,NP) ! ! OUTPUT ENERGY INTERPOLATION SCHEME ON A NEW PAGE ! CALL TOPAGE CALL CANT2(ITAPE,C1,C2,L1,L2,NR,NE,MAT,MF,MT,NBT,INT) CALL INTAB(NBT,INT,NR,1,OUTPUT) ! ! PROCESS EACH INCIDENT ENERGY ! NF = 0 DO 50 J1=1,NE CALL CANT1(ITAPE,C1,E,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) IF(J1.EQ.1) ELO = E IF(J1.EQ.NE) EHI = E NF = MAX0(NF,NP) CALL TOPAGE IF(OUTPUT.GT.0) WRITE(OUTPUT,20) E 20 FORMAT(/' Incident NEUTRON ENERGY',1PE11.4,' eV'/' ',38('-')) CALL INTAB(NBT,INT,NR,1,OUTPUT) CALL WRTAB1(OUTPUT,HEAD(2),UNIT,X,Y,NP) 50 CONTINUE ! RETURN END ! !*********************************************************************** ! SUBROUTINE LIST5B(LF) ! ! PROCESS AND LIST A FILE FIVE MAXWELLIAN, EXAPORATION, WATT OR ! MADLAND-NIX SPECTRUM ! COMMON DUM(107),NR,NP,U,NBT(200),INT(200),X(50000),Y(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/HEADI/ZAI,AWRI,L1I,LFS,NK,N2I,MATI,MFI,MTI COMMON/SFIVE/ELO,EHI,NE,NF ! CHARACTER(LEN=24) HEAD(6) CHARACTER(LEN=24) UNIT(4) ! DATA HEAD /' Energy P(E) ', & & ' Energy Theta(E) ', & & ' X G(X) ', & & ' eV A(E) ', & & ' eV B(E) ', & & ' eV TM(E) '/ DATA UNIT /' eV ', & & ' eV eV ', & & ' ', & & ' eV eV**-1 '/ ! ! OUTPUT PAGE HEADER ! CALL TOPAGE IF(OUTPUT.GT.0.AND.LF.EQ.7) WRITE(OUTPUT,10) 10 FORMAT(/' MAXWELLIAN spectrum, THETA = THETA(E)') IF(OUTPUT.GT.0.AND.LF.EQ.9) WRITE(OUTPUT,20) 20 FORMAT(/' SIMPLE EVAPORATION spectrum, THETA = THETA(E)') IF(OUTPUT.GT.0.AND.LF.EQ.5) WRITE(OUTPUT,30) 30 FORMAT(/' GENERAL EVAPORATION spectrum, THETA = THETA(E), ', & & 'X = E-PRIME/THETA(E)') IF(OUTPUT.GT.0.AND.LF.EQ.11) WRITE(OUTPUT,35) 35 FORMAT(/' WATT FISSION spectrum, A(E) AND B(E)') IF(OUTPUT.GT.0.AND.LF.EQ.12) WRITE(OUTPUT,40) 40 FORMAT(/' MADLAND-NIX FISSION spectrum, TM(E)') IF(OUTPUT.GT.0) WRITE(OUTPUT,45) U 45 FORMAT(' Maximum Energy of the Secondary Particle is ', & & 1PE11.4,' eV') ! ! OUTPUT DISTRIBUTION PROBABILITY WITH INTERPOLATION SCHEME ! CALL INTAB(NBT,INT,NR,1,OUTPUT) CALL WRTAB1(OUTPUT,HEAD(1),UNIT(1),X,Y,NP) ! ! READ AND OUTPUT ENERGY DEPENDENT NUCLEAR TEMPERATURES ! IF(OUTPUT.GT.0) WRITE(OUTPUT,50) 50 FORMAT(/) CALL CANT1(ITAPE,EFL,EFH,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) NF = 0 NE = NP ELO = X(1) EHI = X(NP) CALL INTAB(NBT,INT,NR,1,OUTPUT) IHEAD = 2 IF(LF.EQ.11) IHEAD = 4 IF(LF.NE.12) GO TO 75 IHEAD = 6 IF(OUTPUT.GT.0) WRITE(OUTPUT,60) EFL,EFH 60 FORMAT(' Average Light Fragment KINETIC ENERGY---',1PE11.4,' eV'/ & & ' Average Heavy Fragment KINETIC ENERGY---',1PE11.4,' eV') 75 CALL WRTAB1(OUTPUT,HEAD(IHEAD),UNIT(2),X,Y,NP) ! ! ADDITIONAL TAB1 RECORD FOR GENERAL EVAPORATION AND WATT SPECTRUM ! IF(LF.NE.5.AND.LF.NE.11) GO TO 100 CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) IF(LF.EQ.5) NF = NP IINT = 1 IF(LF.EQ.11) IINT = 6 CALL INTAB(NBT,INT,NR,IINT,OUTPUT) IF(LF.EQ.5) CALL WRTAB1(OUTPUT,HEAD(3),UNIT(3),X,Y,NP) IF(LF.EQ.11) CALL WRTAB1(OUTPUT,HEAD(5),UNIT(4),X,Y,NP) ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE6 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 6 DATA ! COMMON DUM(86),FL(21),ZAP,NR,NP,NBT(200),INT(200),X(50000), & & Y(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/HEADI/ZAI,AWRI,L1I,LCT,NK,N2I,MATI,MFI,MTI COMMON/SSIX/LANG,NE ! CHARACTER(LEN=24) ZAPBCD CHARACTER(LEN=6) SBCD CHARACTER(LEN=8) ZAPSB ! PARAMETER (NPARTS=8) CHARACTER(LEN=10) OPARTS(NPARTS) INTEGER IPARTS(NPARTS) PARAMETER (NLAWS=8) CHARACTER(LEN=30) LTEXT(NLAWS) CHARACTER(LEN=12) LSTEXT(NLAWS) CHARACTER(LEN=24) HEAD CHARACTER(LEN=24) UNIT CHARACTER(LEN=15) LCM(3) ! DATA OPARTS/'PHOTON ','NEUTRON ','PROTON ', & & 'DEUTERON ','TRITON ','ALPHA ', & & 'ELECTRON ','POSITRON '/ DATA IPARTS/0,1,1001,1002,1003,2004,-1000,1000/ ! DATA LTEXT/'UNKNOWN ', & & 'CONTINUUM ENERGY-ANGLE ', & & 'DISCRETE TWO-BODY ', & & 'ISOTROPIC DISCRETE TWO-BODY ', & & 'RECOIL TWO-BODY ', & & 'CHARGED PARTICLE ELASTIC ', & & 'N-BODY PHASE SPACE ', & & 'ANGLE-ENERGY TABULAR '/ DATA LSTEXT/'UNKNOWN(0) ','CONTINUUM(1)','DISCRETE(2) ', & & 'ISOTROPIC(3)','RECOIL(4) ','CP ELAST.(5)', & & 'N-BODY(6) ','ANG-EN(7) '/ ! DATA HEAD/' Energy Number '/ DATA UNIT/' eV '/ DATA LCM/'LABORATORY ','CENTER OF MASS ',' '/ ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,0,ZAI) ! ! SET SECTION IDENTIFICATION INFORMATION ! 5 CALL HEADIN(0,0,MTI,-1.0) ! ! OUTPUT FILE HEADING TO SUMMARY ! CALL FILEHD(MFI) ! ! PROCESS EACH PARTIAL DISTRIBUTION ! DO 190 I=1,NK CALL CANT1(ITAPE,ZAP,C2,LIP,LAW,NR,NP,MAT,MF,MT,NBT,INT,X,Y) NRR = NR NPP = NP ELO = X(1) EHI = X(NP) ! ! OUTPUT PAGE HEADER ! CALL TOPAGE ! ! SET PRODUCT TEXT STRING ! IZAP = ABS(ZAP) + .001 IF(ZAP.LT.0.) IZAP = -IZAP IAP = MOD(IZAP,1000) DO 10 J=1,NPARTS IF(IPARTS(J).EQ.IZAP) GO TO 15 10 CONTINUE CALL ZAID(ZAP,ZAPBCD,IERR) CALL NUSYM(ZAP,SBCD,NSBCD,IERR) ZAPSB = SBCD GO TO 20 15 ZAPBCD = OPARTS(J) ZAPSB = OPARTS(J)(1:8) ! ! IDENTIFY DISTRIBUTION ! 20 IF(OUTPUT.GT.0) THEN IF(LCT.NE.3) THEN WRITE(OUTPUT,25) ZAPBCD,LCM(LCT),LIP 25 FORMAT(/' Distribution for ',A24,' Product in the ',A15, & & 'System; PARTIAL ',I3) ELSE IF(IAP.LE.4) THEN WRITE(OUTPUT,27) ZAPBCD(1:20),LIP 27 FORMAT(/' Distribution for ',A20,' Product Energy/Angle',& & ' in the C.M. System; PARTIAL ',I3) ELSE ! WRITE(OUTPUT,28) ZAPBCD,LIP 28 FORMAT(/' Distribution for ',A20,' Product Energy/Angle',& & ' in the Lab. System; PARTIAL ',I3) END IF END IF END IF ! ! OUTPUT YIELDS ! CALL INTAB(NBT,INT,NR,1,OUTPUT) CALL WRTAB1(OUTPUT,HEAD,UNIT,X,Y,NP) ! ! IDENTIFY THE LAW ! IF(OUTPUT.GT.0) WRITE(OUTPUT,30) LTEXT(LAW+1) 30 FORMAT(/' Product Distribution Law is ',A30) ! ! BRANCH ON LAW ! LF = LAW + 1 LANG = 0 NE = 0 IF(LAW.GT.8) GO TO 200 ! SELECT CASE (LF) ! ! TABULAR FUNCTION ! CASE (2) CALL LIST6A ! ! DISCRETE TWO BODY SCATTERING ! CASE (3) CALL LIST6B ! ! CHARGED PARTICLE ELASTIC ! CASE (6) CALL LIST6C ! ! N-BODY PHASE SPACE ! CASE (7) CALL CONT(ITAPE,APSX,C2,L1,L2,N1,NPSX,MAT,MF,MT) IF(OUTPUT.GT.0) WRITE(OUTPUT,130)NPSX,APSX 130 FORMAT(/I5,' Particles with Mass',1PE11.4, & & ' are described by this law') ! ! ANGLE-ENERGY TABULAR LAW ! CASE (8) CALL LIST6D ! END SELECT ! ! OUTPUT SUMMARY LINE ! 175 IF(I.EQ.1) THEN WRITE(SOUT,180) MTI,MTBCD,ZAPSB,LSTEXT(LAW+1),NPP, & & ELO,EHI,NRR,LANG,NE 180 FORMAT(/I6,3X,A30,1X,A8,2X,A12,I8,3X,1PE11.4,1X,1PE11.4,I5, & & 7X,I3,I7) ELSE WRITE(SOUT,185) ZAPSB,LSTEXT(LAW+1),NPP,ELO,EHI,NRR, & & LANG,NE 185 FORMAT(40X,A8,2X,A12,I8,3X,1PE11.4,1X,1PE11.4,I5,7X,I3,I7) END IF ! 190 CONTINUE ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) GO TO 250 ! ! INVALID LAW, SKIP REST OF SECTION ! 200 IF(OUTPUT.GT.0) WRITE(OUTPUT,210) LAW 210 FORMAT(//5X,'LAW = ',I2,' IS ILLEGAL. REST OF SECTION IS SKIPPED') CALL SKPSEC(ITAPE) ! ! CHECK FOR NEW SECTION OR END OF FILE ! 250 CALL CONT(ITAPE,ZAI,AWRI,L1I,LCT,NK,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 5 ! RETURN END ! !*********************************************************************** ! SUBROUTINE LIST6A ! ! ROUTINE TO PROCESS CONTINUUM EMISSION REPRESENTATIONS ! COMMON DUM(108),NR,NP,NBT(200),INT(200),B(50000),X(7500),Y(7500), & & DUM1(35000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/SSIX/LANG,NE ! CHARACTER(LEN=24) HEAD CHARACTER(LEN=24) UNIT CHARACTER(LEN=12) EXPAN(2) CHARACTER(LEN=24) ILAW(5) CHARACTER(LEN=24) JLAW(5) ! DATA HEAD/' MU F(MU) '/ DATA UNIT/' '/ DATA EXPAN/'LEGENDRE ','KALBACH-MANN'/ ! DATA ILAW /'F(E'') HISTOGRAM IN E'' ', & & 'F(E'') LINEAR IN E'' ', & & 'F(E'') LINEAR IN LN E'' ', & & 'LN F(E'') LINEAR IN E'' ', & & 'LN F(E'') LINEAR IN LN E'''/ DATA JLAW /'F(MU) HISTOGRAM IN MU ', & & 'F(MU) LINEAR IN MU ', & & 'F(MU) LINEAR IN LN MU ', & & 'LN F(MU) LINEAR IN MU ', & & 'LN F(MU) LINEAR IN LN MU'/ ! ! READ TAB2 RECORD AND OUTPUT CONTENTS ! CALL CANT2(ITAPE,C1,C2,LANG,LEP,NR,NE,MAT,MF,MT,NBT,INT) CALL INTAB(NBT,INT,NR,1,OUTPUT) IF(OUTPUT.GT.0) WRITE(OUTPUT,10) ILAW(LEP) 10 FORMAT(/' Interpolation Law between Emitted Particle Energies ', & & 'is ',A24) ! ! PROCESS EACH ENERGY ! DO 200 N=1,NE CALL CANT(ITAPE,C1,E,ND,NA,NW,NEP,MAT,MF,MT,B) IF(N.NE.1) CALL TOPAGE ! ! LEGENDRE OR KALBACH-MANN EXPANSION ! IF(LANG.LE.2) THEN IF(OUTPUT.GT.0) WRITE(OUTPUT,20) EXPAN(LANG),E 20 FORMAT(//' ',A12,' Expansion of the Emitted Particle ', & & 'Distribution at',1PE11.4,' eV') GO TO 50 END IF ! ! TABULATED DISTRIBUTION ! 30 INTER = LANG - 10 IF(OUTPUT.GT.0) WRITE(OUTPUT,35) E,JLAW(INTER) 35 FORMAT(//' Tabulated Emitted Particle Distribution at',1PE11.4, & & ' eV with ',A24,' interpolation') ! ! PROCESS EACH EMITTED PARTICLE ENERGY ! 50 KN = 1 DO 185 NN=1,NEP EP = B(KN) ! ! A DISCRETE EMITTED ENERGY ! IF(NN.GT.ND) GO TO 80 IPRI = 0 IF(EP.LT.0.) IPRI = 1 IF(OUTPUT.GT.0.AND.IPRI.EQ.0) WRITE(OUTPUT,60) EP 60 FORMAT(/' Discrete Emitted Particle ENERGY is',1PE11.4) IF(OUTPUT.GT.0.AND.IPRI.EQ.1) WRITE(OUTPUT,70) -EP 70 FORMAT(/' Primary Photon ENERGY is',1PE11.4) GO TO 100 ! ! A CONTINUUM EMITTED ENERGY ! 80 IF(OUTPUT.GT.0) WRITE(OUTPUT,90) EP 90 FORMAT(/' Emitted Particle ENERGY is',1PE11.4) ! ! OUTPUT DATA FOR THIS EMITTED ENERGY ! 100 KN = KN + 1 ! ! OUTPUT LEGENDRE PARAMETERS ! IF(LANG.EQ.1) THEN KU = KN + NA IF(OUTPUT.GT.0) WRITE(OUTPUT,110) ((J-KN),B(J),J=KN,KU) 110 FORMAT((8(I3,1PE11.4))) GO TO 180 END IF ! ! OUTPUT KALBACH-MANN PARAMETERS ! 120 IF(LANG.EQ.2) THEN KU = KN + NA IF(OUTPUT.GT.0) WRITE(OUTPUT,130) B(KN),B(KN+1) 130 FORMAT(7X,'F(0)=',1PE11.4,5X,'R=',1PE11.4) GO TO 180 END IF ! ! TABULAR FUNCTION ! NP = 0 DO KK=KN,KU,2 NP = NP + 1 X(NP) = B(KK) Y(NP) = B(KK+1) END DO CALL WRTAB1(OUTPUT,HEAD,UNIT,X,Y,NP) 180 KN = KU + 1 185 CONTINUE 200 CONTINUE ! RETURN END ! !*********************************************************************** ! SUBROUTINE LIST6B ! ! ROUTINE TO PROCESS DISCRETE TWO-BODY REPRESENTATIONS ! COMMON DUM(108),NR,NP,NBT(200),INT(200),B(50000),X(7500),Y(7500), & & DUM1(35000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/SSIX/LANG,NE ! CHARACTER(LEN=24) HEAD CHARACTER(LEN=24) UNIT CHARACTER(LEN=24) JLAW(5) ! DATA HEAD/' MU F(MU) '/ DATA UNIT/' '/ ! DATA JLAW /'F(MU) HISTOGRAM IN MU ', & & 'F(MU) LINEAR IN MU ', & & 'F(MU) LINEAR IN LN MU ', & & 'LN F(MU) LINEAR IN MU ', & & 'LN F(MU) LINEAR IN LN MU'/ ! ! READ TAB2 RECORD AND OUTPUT CONTENTS ! CALL CANT2(ITAPE,C1,C2,L1,L2,NR,NE,MAT,MF,MT,NBT,INT) CALL INTAB(NBT,INT,NR,1,OUTPUT) ! ! PROCESS EACH ENERGY ! DO 100 N=1,NE CALL CANT(ITAPE,C1,E,LTP,L2,NW,NL,MAT,MF,MT,B) LANG = LTP IF(N.NE.1) CALL TOPAGE ! ! LEGENDRE EXPANSION ! IF(LANG.NE.0) GO TO 30 IF(OUTPUT.GT.0) WRITE(OUTPUT,20) E,NL 20 FORMAT(/' Emitted Particle Angular Distribution at',1PE11.4, & & ' eV is represented by ',I2,' LEGENDRE COEFFICIENTS') IF(OUTPUT.GT.0) WRITE(OUTPUT,25) (J,B(J),J=1,NL) 25 FORMAT((8(I3,1PE11.4))) GO TO 100 ! ! TABULATED DISTRIBUTION ! 30 INTER = LANG - 10 IF(OUTPUT.GT.0) WRITE(OUTPUT,35) E,JLAW(INTER) 35 FORMAT(//' Tabulated Emitted Particle Distribution at',1PE11.4, & & ' eV with ',A24,' INTERPOLATION') NP = 0 DO KK=1,NW,2 NP = NP + 1 X(NP) = B(KK) Y(NP) = B(KK+1) END DO CALL WRTAB1(OUTPUT,HEAD,UNIT,X,Y,NP) 100 CONTINUE ! RETURN END ! !*********************************************************************** ! SUBROUTINE LIST6C ! ! ROUTINE TO PROCESS CHARGED PARTICLE ELASTIC REPRESENTATIONS ! COMMON DUM(108),NR,NP,NBT(200),INT(200),X(50000),Y(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/SSIX/LTP,NE ! CHARACTER(LEN=24) HEAD CHARACTER(LEN=24) UNIT CHARACTER(LEN=29) ILAW(4) ! DATA HEAD/' Cosine Dsigma '/ DATA UNIT/' Barns/Sr '/ ! DATA ILAW /'DSIGMA LINEAR IN COSINE ', & & 'DSIGMA LINEAR IN LN COSINE ', & & 'LN DSIGMA LINEAR IN COSINE ', & & 'LN DSIGMA LINEAR IN LN COSINE'/ ! ! READ TAB2 RECORD AND OUTPUT CONTENTS ! CALL CANT2(ITAPE,SPI,C2,LIDP,L2,NR,NE,MAT,MF,MT,NBT,INT) IF(OUTPUT.GT.0.AND.LIDP.NE.0) WRITE(OUTPUT,10) SPI 10 FORMAT(' Scattering of Identical Particles with SPIN ',F3.1) CALL INTAB(NBT,INT,NR,1,OUTPUT) ! ! PROCESS EACH ENERGY ! DO 100 N=1,NE CALL CANT(ITAPE,C1,E,LTP,L2,NW,NL,MAT,MF,MT,X) IF(N.NE.1) CALL TOPAGE ! ! RESIDUAL CROSS SECTION TABULATED ! IF(LTP.LE.10) GO TO 30 INTER = LTP - 10 NIP = 1 DO I=1,NL X(I) = X(NIP) Y(I) = X(NIP+1) NIP = NIP + 2 END DO NP = NL IF(OUTPUT.GT.0) WRITE(OUTPUT,25) E,ILAW(INTER) 25 FORMAT(//' Residual Cross Section Tabulated at',1PE11.4,' eV', & & ' with ',A29,' INTERPOLATION') CALL WRTAB1(OUTPUT,HEAD,UNIT,X,Y,NP) GO TO 100 ! ! RESIDUAL CROSS SECTION AS LEGENDRE EXPANSION ! 30 IF(LTP.NE.2) GO TO 50 WRITE(OUTPUT,35) E 35 FORMAT(//' Legendre Expansion of the Residual Reaction at', & & 1PE11.4,' eV') IF(OUTPUT.GT.0.AND.LIDP.EQ.1) & & WRITE(OUTPUT,40) (2*(J-1),X(J),J=1,NW) IF(OUTPUT.GT.0.AND.LIDP.EQ.0) WRITE(OUTPUT,40) ((J-1),X(J),J=1,NW) 40 FORMAT((8(I3,1PE11.4))) GO TO 100 ! ! NUCLEAR AMPLITUDE LEGENDRE EXPANSION ! 50 IF(LTP.NE.1) GO TO 100 IF(OUTPUT.GT.0) WRITE(OUTPUT,55) E 55 FORMAT(//' Legendre Expansion of the Reaction Amplitude at', & & 1PE11.4,' eV'//' NUCLEAR TERM') IF(OUTPUT.GT.0.AND.LIDP.EQ.1) & & WRITE(OUTPUT,40) (2*(J-1),X(J),J=1,NL+1) IF(OUTPUT.GT.0.AND.LIDP.EQ.0) & & WRITE(OUTPUT,40) ((J-1),X(J),J=1,2*NL+1) IF(OUTPUT.GT.0) WRITE(OUTPUT,60) 60 FORMAT(/' COMPLEX INTERFERENCE TERM') JB = NL + 2 IF(LIDP.EQ.1) JB = JB + NL JJB = (J-JB)/2 IF(OUTPUT.GT.0) & & WRITE(OUTPUT,80) (JJB,X(J),JJB,X(J+1),J=JB,NW,2) 80 FORMAT((4(I3,'R',1PE11.4,I3,'I',1PE11.4))) ! 100 CONTINUE ! RETURN END ! !*********************************************************************** ! SUBROUTINE LIST6D ! ! ROUTINE TO PROCESS CONTINUUM EMISSION REPRESENTATIONS ! COMMON DUM(108),NR,NP,NBT(200),INT(200),B(50000),X(7500),Y(7500), & & DUM1(35000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/SSIX/LANG,NE ! CHARACTER(LEN=24) HEAD CHARACTER(LEN=24) UNIT ! DATA HEAD/' E'' F(E'') '/ DATA UNIT/' eV '/ ! ! READ TAB2 RECORD AND OUTPUT CONTENTS ! CALL CANT2(ITAPE,C1,C2,L1,L2,NR,NE,MAT,MF,MT,NBT,INT) LANG = 0 CALL INTAB(NBT,INT,NR,1,OUTPUT) ! ! PROCESS EACH ENERGY ! DO 200 N=1,NE CALL CANT2(ITAPE,C1,E,L1,L2,NRM,NMU,MAT,MF,MT,NBT,INT) IF(N.NE.1) CALL TOPAGE IF(OUTPUT.GT.0) WRITE(OUTPUT,20) E 20 FORMAT(/' Incident Particle Energy',1PE11.4,' eV'/' ',38('-')) CALL INTAB(NBT,INT,NRM,2,OUTPUT) ! ! PROCESS EACH ANGLE ! DO NM=1,NMU CALL CANT1(ITAPE,C1,FMU,L1,L2,NREP,NEP,MAT,MF,MT,NBT,INT,X,Y) IF(OUTPUT.GT.0) WRITE(OUTPUT,25) FMU 25 FORMAT(/' Outgoing Particle ANGLE COSINE',1PE11.4,' eV'/ & & ' ',44('-')) CALL INTAB(NBT,INT,NREP,1,OUTPUT) CALL WRTAB1(OUTPUT,HEAD,UNIT,X,Y,NEP) END DO 200 CONTINUE ! RETURN END ! !*********************************************************************** ! SUBROUTINE LIST6E ! ! ROUTINE TO PROCESS ENERGY TRANSFER REPRESENTATION ! COMMON DUM(108),NR,NP,NBT(200),INT(200),B(50000),X(7500),Y(7500), & & DUM1(35000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/SSIX/LANG,NE ! CHARACTER(LEN=24) HEAD CHARACTER(LEN=24) UNIT ! DATA HEAD/' E ET(E) '/ DATA UNIT/' eV eV '/ ! CALL CANT1(ITAPE,C1,C2,L1,LR,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL TOPAGE IF(OUTPUT.GT.0) WRITE(OUTPUT,20) 20 FORMAT(/' ',38('-')) CALL INTAB(NBT,INT,NR,1,OUTPUT) CALL WRTAB1(OUTPUT,HEAD,UNIT,X,Y,NP) 200 CONTINUE ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE7 ! ! ROUTINE TO CONTROL PROCESSING OF THERMAL LAW DATA ! COMMON DUM(110),NBT(200),INT(200),ALPHA(50000),S(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR COMMON/HEADI/ZAI,AWRI,LTHR,LAT,N1I,N2I,MATI,MFI,MTI ! REAL B(30),CFLAG(4) ! CHARACTER(LEN=24) HEAD(5) CHARACTER(LEN=24) UNIT(5) CHARACTER(LEN=16) MODEL(3) CHARACTER(LEN=20) INLAWS(6) ! DATA HEAD /' Alpha S(Alpha) ', & & ' T-Mod T-Eff ', & & ' Energy Factor ', & & ' Temp Data ', & & ' Alpha ln(S(Alpha))'/ DATA UNIT /' ', & & ' Kelvin Kelvin ', & & ' eV eV-Barns ', & & ' Kelvin eV**-1 ', & & ' '/ ! DATA MODEL/' TABULATED ',' FREE GAS LAW ', & & 'DIFFUSIVE MOTION'/ DATA INLAWS /'CONSTANT ', & & 'Y LINEAR IN X ', & & 'Y LINEAR IN LN X ', & & 'LN Y LINEAR IN X ', & & 'LN Y LINEAR IN LN X ', & & '******(ERROR)*******'/ ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,0,ZAI) ! ! SET SECTION IDENTIFICATION INFORMATION ! 10 CALL HEADIN(0,0,MTI,-1.) ! ! PRINT PAGE HEADER ! CALL TOPAGE ! ! INCOHERENT INELASTIC SCATTERING ! IF(LTHR.GT.0) GO TO 300 ! ! READ IN AND PRINT CONSTANTS ! CALL CANT(ITAPE,C1,C2,LLN,L2,NL,NS,MAT,MF,MT,B) DO NNN=1,NS+1 CFLAG(NNN) = B(6*(NNN-1)+1) END DO ! ! WRITE OUT PHYSICAL CONSTANTS FOR TABULAR LAW ! IF(CFLAG(1).LE.0.0) GO TO 40 IF(OUTPUT.GT.0) WRITE(OUTPUT,20) 20 FORMAT(/' Index',6X,'Type',14X,'Total',10X,'Effective',11X, & & 'Constant',6X,'Static Elastic'/ & & 13X,'of',13X,'Free Atom',10X,'Mass',13X,'Free Atom',8X, & & 'Scattering'/ & & 11X,'Model',10X,'Cross Section',23X,'Cross Section',5X, & & 'Energy Limit'/ & & 63X,'Energy Limit',8X,'(E.KT)'/) IF(OUTPUT.GT.0) WRITE(OUTPUT,30) MODEL(1),B(1),B(3),B(4),B(2) 30 FORMAT(' 0 ',A16,1X,4(3X,1PE11.4,4X)) GO TO 75 ! ! WRITE HEADING FOR CONSTANTS FOR ANALYTIC FUNCTION ONLY ! 40 IF(OUTPUT.GT.0) WRITE(OUTPUT,50) 50 FORMAT(/' Index',6X,'Type',14X,'Total',10X,'Effective'/ & & 13X,'of',13X,'Free Atom',10X,'Mass'/ & & 11X,'Model',10X,'Cross Section') ! ! PROCESS ALL CONSTANTS FOR ANALYTIC FUNCTIONS ! 75 IF(NS.LE.0) GO TO 100 IAOFF = 6 DO JNDEX=1,NS INDEX = B(IAOFF+1) + 1 IF(OUTPUT.GT.0) WRITE(OUTPUT,80) JNDEX,MODEL(INDEX), & & B(IAOFF+2),B(IAOFF+3) 80 FORMAT(I4,2X,A16,1X,2(3X,1PE11.4,4X)) IAOFF = IAOFF + 6 END DO ! ! PROCESS INTERPOLATION SCHEME FOR BETA ! 100 IF(B(1).LE.0.0) GO TO 250 CALL CANT2(ITAPE,C1,C2,L1,L2,NR,NB,MAT,MF,MT,NBT,INT) CALL TOPAGE IF(OUTPUT.GT.0.AND.LAT.EQ.0) WRITE(OUTPUT,110) 110 FORMAT(/' The ACTUAL Temperarure was used to compute ', & & 'ALPHA and BETA') IF(OUTPUT.GT.0.AND.LAT.EQ.1) WRITE(OUTPUT,120) 120 FORMAT(/' ALPHA and BETA were computed using a Temperature of ', & & '293.62 DEGREES KELVIN (0.0253 EV) instead of the Actual ', & & 'Temperature') CALL INTAB(NBT,INT,NR,4,OUTPUT) ! ! PROCESS FOR ALL VALUES OF BETA TABULATED ! IHEAD = 1 IF(LLN.EQ.1) IHEAD = 5 DO 200 J=1,NB CALL CANT1(ITAPE,T,BETA,LT,L2,NR,NP,MAT,MF,MT,NBT,INT,ALPHA,S) CALL TOPAGE IF(OUTPUT.GT.0) WRITE(OUTPUT,130) T,BETA 130 FORMAT(/' Temperature=',1PE11.4,' DEGREES KELVIN',53X,'BETA=', & & 1PE11.4) CALL INTAB(NBT,INT,NR,5,OUTPUT) IF(OUTPUT.GT.0) WRITE(OUTPUT,140) 140 FORMAT(/' TABULATED THERMAL SCATTERING LAW') CALL WRTAB1(OUTPUT,HEAD(IHEAD),UNIT(IHEAD),ALPHA,S,NP) IF(LT.LE.0)GO TO 200 DO 190 K=1,LT TLAST=T CALL CANT(ITAPE,T,C2,INTER,L2,NP,N2,MAT,MF,MT,S) CALL TOPAGE IF(OUTPUT.GT.0) WRITE(OUTPUT,130) T,BETA IF(INTER.LT.1.OR.INTER.GT.5) INTER=6 IF(OUTPUT.GT.0) WRITE(OUTPUT,160) TLAST,T,INLAWS(INTER) 160 FORMAT(' Interpolation Law between Temperature=',1PE11.4, & & ' and Temperature=',1PE11.4,' is ',A20) CALL INTAB(NBT,INT,NR,5,OUTPUT) CALL WRTAB1(OUTPUT,HEAD(1),UNIT(1),ALPHA,S,NP) 190 CONTINUE 200 CONTINUE ! ! PROCESS EFFECTIVE TEMPERATURE RECORD ! 250 IF(NFOR.LT.6) GO TO 500 CALL TOPAGE CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NT,MAT,MF,MT,NBT,INT,ALPHA,S) CALL INTAB(NBT,INT,NR,3,OUTPUT) IF(OUTPUT.GT.0) WRITE(OUTPUT,260) 260 FORMAT(//' TABLE OF EFFECTIVE TEMPERATURES FOR PRINCIPLE ATOM') CALL WRTAB1(OUTPUT,HEAD(2),UNIT(2),ALPHA,S,NT) IF(NS.LE.0) GO TO 500 DO 280 NN=1,NS IF(CFLAG(NN+1).GT.0.) GO TO 280 CALL TOPAGE CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NT,MAT,MF,MT,NBT,INT,ALPHA,S) CALL INTAB(NBT,INT,NR,3,OUTPUT) IF(OUTPUT.GT.0) WRITE(OUTPUT,270) B(6*NN+3) 270 FORMAT(//' TABLE OF EFFECTIVE TEMPERATURES FOR ATOM WITH', & & ' EFFECTIVE MASS EQUAL TO ',1PE11.4) CALL WRTAB1(OUTPUT,HEAD(2),UNIT(2),ALPHA,S,NT) 280 CONTINUE GO TO 500 ! ! COHERENT ELASTIC SCATTERING ! 300 IF(LTHR.NE.1) GO TO 400 CALL CANT1(ITAPE,T,C2,LT,L2,NR,NP,MAT,MF,MT,NBT,INT,ALPHA,S) IF(OUTPUT.GT.0) WRITE(OUTPUT,310) 310 FORMAT(/' COHERENT ELASTIC SCATTERING') CALL INTAB(NBT,INT,NR,1,OUTPUT) IF(LT.GT.0) CALL TOPAGE IF(OUTPUT.GT.0) WRITE(OUTPUT,320) T 320 FORMAT(//' TABULATED STRUCTURE FACTORS AT',1PE11.4,' DEGREES ', & & 'KELVIN') CALL WRTAB1(OUTPUT,HEAD(3),UNIT(3),ALPHA,S,NP) IF(LT.LE.0)GO TO 500 DO 390 K=1,LT TLAST=T CALL CANT(ITAPE,T,C2,INTER,L2,NP,N2,MAT,MF,MT,S) CALL TOPAGE IF(OUTPUT.GT.0) WRITE(OUTPUT,320) T IF(INTER.LT.1.OR.INTER.GT.5) INTER=6 IF(OUTPUT.GT.0) WRITE(OUTPUT,330) TLAST,T,INLAWS(INTER) 330 FORMAT(' Interpolation Law between Temperature=',1PE11.4, & & ' and Temperature=',1PE11.4,' is ',A20) CALL INTAB(NBT,INT,NR,5,OUTPUT) CALL WRTAB1(OUTPUT,HEAD(3),UNIT(3),ALPHA,S,NP) 390 CONTINUE GO TO 500 ! ! INCOHERENT ELASTIC SCATTERING ! 400 IF(LTHR.NE.2) GO TO 500 CALL CANT1(ITAPE,SB,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,ALPHA,S) IF(OUTPUT.GT.0) WRITE(OUTPUT,410) SB 410 FORMAT(//' ELASTIC INCOHERENT SCATTERING'/ & & ' CHARACTERISTIC BOUND CROSS SECTION IS',1PE11.4,' BARNS') CALL INTAB(NBT,INT,NR,3,OUTPUT) IF(OUTPUT.GT.0) WRITE(OUTPUT,420) 420 FORMAT(/' DEBYE-WALLER INTEGRAL/A') CALL WRTAB1(OUTPUT,HEAD(4),UNIT(4),ALPHA,S,NP) ! ! SKIP SEND RECORD ! 500 CALL SKPREC(ITAPE,1) ! ! CHECK FOR NEW SECTION OR END OF FILE ! CALL CONT(ITAPE,ZAI,AWRI,LTHR,LAT,N1I,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE8 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 8 DATA ! COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,0,ZAI) ! ! OUTPUT FILE HEADING TO SUMMARY ! CALL FILEHD(MFI) ! ! SET SECTION ID AND BRANCH ON SECTION ! 10 CALL HEADIN(0,0,MTI,-1.0) IF(MTI.EQ.454.OR.MTI.EQ.459) GO TO 20 IF(MTI.EQ.457) GO TO 30 ! ! RADIOACTIVE NUCLIDE PRODUCTION ! CALL FILE8A GO TO 100 ! ! FISSION PRODUCT YIELDS ! 20 CALL FILE8B GO TO 100 ! ! DECAY DATA ! 30 CALL FILE8C ! ! LOOK FOR FILE END CARD ! 100 CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI) IF(MFI.NE.0)GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE8A ! ! RADIOACTIVE NUCLIDE PRODUCTION ! COMMON DUM(510),E(1000),DUM1(50000),DUM2(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,DZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) DZABCD COMMON/HEADI/ZA,AWR,LIS,LISO,NS,N0,MATI,MFI,MTI ! CHARACTER(LEN=24) ZABCD CHARACTER(LEN=24) ZAPBCD CHARACTER(LEN=6) SZBCD ! CHARACTER(LEN=18) RDATA(3) DATA RDATA/'CROSS SECTIONS(3) ', & & 'MULTIPLICITIES(9) ','CROSS SECTIONS(10)'/ ! ! GET TARGET NUCLIDE EXPANSION ! CALL ZAID(ZA,ZABCD,IERR) ! ! OUTPUT PAGE HEADER ! CALL TOPAGE ! ! PROCESS EACH STATE ! DO 200 N=1,NS IF(N0.EQ.1) THEN CALL CONT(ITAPE,ZAP,ELFS,LMF,LFSO,NZ,MATP,MAT,MF,MT) IREP = 1 ELSE CALL CANT(ITAPE,ZAP,ELFS,LMF,LFSO,NZ,MATP,MAT,MF,MT,E) IREP = LMF - 7 END IF ! ! DECODE PRODUCT NUCLIDE ! CALL ZAID(ZAP,ZAPBCD,IERR) CALL NUSYM(ZAP,SZBCD,NSZBCD,IERR) ! ! WRITE OUT INITIAL STATE ! IF(LISO.EQ.0) THEN IF(OUTPUT.GT.0) WRITE(OUTPUT,20) N,ZABCD 20 FORMAT(///' Reaction ',I3/' ------------'/ & & ' Original Nuclide= ',A24,' (GROUND state)') ELSE IF(OUTPUT.GT.0) WRITE(OUTPUT,50) ZABCD,MAX0(LISO,LIS) 50 FORMAT(' Original Nuclide= ',A24, & & ' (',I3,'-EXCITED state)') END IF ! ! WRITE OUT FINAL STATE ! 60 IF(LFSO.EQ.0) THEN IF(OUTPUT.GT.0) WRITE(OUTPUT,70) ZAPBCD 70 FORMAT(' Product Nuclide= ',A24,' (GROUND state)') ELSE IF(OUTPUT.GT.0) WRITE(OUTPUT,90) ZAPBCD,LFSO 90 FORMAT(' Product Nuclide= ',A24, & & ' (',I3,'-EXCITED state)') END IF ! ! OUTPUT ADDITIONAL PRODUCT PARAMETERS ! 100 IF(OUTPUT.GT.0) THEN IF(MATP.NE.0) WRITE(OUTPUT,105) MATP 105 FORMAT(7X,'Reaction Product Material Number = ', & & I4) IF(ELFS.NE.0.0) WRITE(OUTPUT,110) ELFS 110 FORMAT(7X,'Excitation Energy of Product =', & & 1PE11.4,' eV') WRITE(OUTPUT,115) LMF 115 FORMAT(7X,'Multiplicity/Cross Section File Number = ', & & I2/) END IF ! ! PROCESS EACH DECAY MODE ! ND = NZ/6 IF(NZ.EQ.0) GO TO 150 IF(OUTPUT.GT.0) WRITE(OUTPUT,120) 120 FORMAT(' Branch Number ZAP Half-life Mode of Decay', & & ' Next Nuclide(ZAN) ZAN Branching Ratio ', & & 'End-point Energy Chain Terminator'/) DO 140 K=1,NZ,6 KK=K+5 K3 = KK IF(K3.GT.NZ)K3=NZ KK=KK/6 IF(OUTPUT.GT.0) WRITE(OUTPUT,130)KK,(E(K2),K2=K,K3) 130 FORMAT(8X,I3,4X,6(8X,1PE11.4)) 140 CONTINUE ! ! OUTPUT LINE TO SUMMARY ! 150 IF(N.EQ.1) THEN WRITE(SOUT,160) MTI,MTBCD,SZBCD,MATP,LFSO,ELFS,RDATA(IREP),ND 160 FORMAT(/I6,3X,A30,4X,A6,6X,I4,6X,I3,5X,1PE11.4,3X,A18,4X,I3) ELSE WRITE(SOUT,170) SZBCD,MATP,LFSO,ELFS,RDATA(IREP),ND 170 FORMAT(43X,A6,6X,I4,6X,I3,5X,1PE11.4,3X,A18,4X,I3) END IF 200 CONTINUE ! ! SKIP SEND CARD ! CALL SKPREC(ITAPE,1) ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE8B ! ! FISSION PRODUCT YIELDS ! COMMON DUM(509),INTE,C(50000),DUM1(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI ! ! READ FIRST SECTION ! I=0 CALL CANT(ITAPE,E,C2,LE,L2,N2NFP,NFP,MATI,MFI,MTI,C) ELO = E NE = LE + 1 INTE=LE CALL LIST8B(NFP,I,E) ! ! SET UP LOOP TO READ ALL OTHER SECTIONS ! IF(LE.LE.0) GO TO 100 DO 50 I=1,LE II = I CALL CANT(ITAPE,E,C2,INTE,L2,N2NFP,NFP,MAT,MF,MT,C) CALL HEADIN(0,0,MT,-1.0) CALL LIST8B(NFP,II,E) 50 CONTINUE ! ! OUTPUT TO SUMMARY ! 100 EHI = E WRITE(SOUT,110) MTI,MTBCD,NFP,NE,ELO,EHI 110 FORMAT(/I6,3X,A30,4X,I4,' FISSION PRODUCTS specified at',I3, & & ' ENERGIES between',1PE11.4,' and',1PE11.4,' eV') ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) ! RETURN END ! !*********************************************************************** ! SUBROUTINE LIST8B(NFP,IF1D,E) ! ! PRINT FISSION PRODUCT YIELDS ! COMMON DUM(509),INTE,C(50000),DUM1(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT ! CHARACTER(LEN=6) ZABCDS(3) CHARACTER(LEN=1) IFLAG(3) REAL YLD(3),DYLD(3) ! ! WRITE HEADING FOR PAGE ! CALL TOPAGE ! ! WRITE OUT ENERGY AND INTERPOLATION ! IF(OUTPUT.GT.0.AND.E.GT.0.0) WRITE(OUTPUT,10) E 10 FORMAT(/29X,' Incident Neutron Energy ',1PE11.4,' eV'/) IF(OUTPUT.GT.0.AND.IF1D.GT.0) WRITE(OUTPUT,20) INTE 20 FORMAT(29X,' Interpolation Law for Last Interval=',I2/) ! ! WRITE OUT COLUMN HEADINGS ! IF(OUTPUT.GT.0) WRITE(OUTPUT,30) 30 FORMAT(' Index ',3(' Fission Fractional Yield ')/ & & ' ',3(' Product Yield Uncertainty')) ! ! PRINT YIELDS IN GROUPS OF THREE ! JJ=1 IFC=0 DO 100 I=1,NFP,3 JMAX = MIN0(3,NFP-(JJ-1)/4) DO 80 J=1,JMAX ! ! SET PRODUCT TEXT ID ! CALL NUSYM(C(JJ),ZABCDS(J),NZAB,IERR) ! ! GET YIELD AND UNCERTAINTY FOR PRODUCT ! YLD(J)=C(JJ+2) DYLD(J) = C(JJ+3) ! ! SET ISOMER FLAG ! IFLAG(J) = ' ' IF(C(JJ+1).GE.1.0) THEN IFC=1 IFLAG(J) = '*' END IF JJ = JJ + 4 80 CONTINUE IF(OUTPUT.GT.0) WRITE(OUTPUT,90) I,(IFLAG(J),ZABCDS(J), & & YLD(J),DYLD(J),J=1,JMAX) 90 FORMAT(I7,1X,3(A1,1X,A6,10X,1PE12.5,1PE11.4)) 100 CONTINUE ! ! DEFINE ISOMER FLAG IF USED ! IF(OUTPUT.GT.0.AND.IFC.GT.0) WRITE(OUTPUT,110) 110 FORMAT(// 9X,'* Excited State') ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE8C ! ! DECAY DATA ! COMMON DUM(276),E(34),INT(100),NBT(100),B(5000),DUM1(45000), & & X(5000),Y(5000),DUM2(40000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,DZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) DZABCD COMMON/HEADI/ZAI,AWRI,LIS,LISO,N1I,NSP,MATI,MFI,MTI ! CHARACTER(LEN=1) NSTTE CHARACTER(LEN=1) ITIME CHARACTER(LEN=1) PRTY CHARACTER(LEN=18) IC CHARACTER(LEN=24) ZABCD ! CHARACTER(LEN=2) FLIS(4) CHARACTER(LEN=16) COV(2) PARAMETER (NTIMES=4) CHARACTER(LEN=1) NTIME(NTIMES) REAL TIMAX(NTIMES) CHARACTER(LEN=12) NRTYP(11) CHARACTER(LEN=16) NSTYP(10) CHARACTER(LEN=12) NTYP(4) ! DATA FLIS/'ST','ND','RD','TH'/ DATA COV/' ','WITH COVARIANCES'/ ! ! TABLES FOR TIME CONVERSIONS ! DATA NTIME/'M','H','D','Y'/ DATA TIMAX/60.,60.,24.,365.25/ ! ! TABLE OF DECAY TYPES ! DATA NRTYP /'GAMMA RAY ','BETA DECAY ', & & 'E.C./POS EMI','ISOM TRANS ', & & 'ALPHA DECAY ','NEUTRON EMIS', & & 'SPONT FISSN ','PROTON EMIS ', & & 'NOT DEFINED ','NOT DEFINED ', & & 'UNKNOWN ORIG'/ ! ! TABLE OF RADIATION TYPES ! DATA NSTYP /'GAMMA RAYS ','BETA RAYS ', & & 'E.C. OR POS EMIS','NOT DEFINED ', & & 'ALPHA PARTICLE ','NEUTRONS ', & & 'SPONT FIS FRAGS ','PROTONS ', & & 'DISCRETE ELECTS ','XRAYS/ANNIL RAD '/ ! ! TABLE OF BETA TRANSITION TYPES ! DATA NTYP /'NOT REQUIRED','ALLOWED ', & & '1ST-FORBIDDN','2ND-FORBIDDN'/ ! ! WRITE HEADING ON PAGE ! CALL TOPAGE ! ! OUTPUT NUCLIDE AND LEVEL IDENTIFIER ! NIS = MIN0(LIS,4) NIS0 = MIN0(LISO,4) CALL ZAID(ZAI,ZABCD,IERR) IF(LIS.GT.0) GO TO 20 IF(OUTPUT.GT.0) WRITE(OUTPUT,10) ZABCD 10 FORMAT(//44X,'Radioactive Nuclide GROUND State of ',A20) GO TO 40 20 IF(LISO.GT.0) GO TO 30 IF(OUTPUT.GT.0) WRITE(OUTPUT,25) LIS,FLIS(NIS),ZABCD 25 FORMAT(//40X,'Radioactive Nuclide ',I2,A2,' EXCITED State of ', & & A24) GO TO 40 30 IF(OUTPUT.GT.0) WRITE(OUTPUT,35) LIS,FLIS(NIS),LISO, & & FLIS(NIS0),ZABCD 35 FORMAT(//40X,'Radioactive Nuclide ',I2,A2,' EXCITED State (',I2, & & A2,' ISOMERIC State) of ',A24) ! ! READ FIRST RECORD ! 40 CALL CANT(ITAPE,C1,C2,L1,L2,N1,N2,MAT,MF,MT,E) ! ! CONVERT HALF-LIFE ! HL = C1 DHL = C2 ITIME = 'S' DO I=1,NTIMES TIM = TIMAX(I) IF(HL.LT.TIM) GO TO 60 ITIME = NTIME(I) HL = HL/TIM DHL = DHL/TIM END DO ! ! PROCESS LIST OF DECAY MODES ! 60 CALL CANT(ITAPE,C1,C2,L1,L2,N1,NDK,MAT,MF,MT,B) ! ! OUTPUT SPIN PARITY AND HALF-LIFE ! PRTY = '+' IF(C2.LT.0.0) PRTY = '-' IF(OUTPUT.EQ.0) GO TO 68 ASPIN = ABS(C1) IF(ASPIN.NE.77.777) WRITE(OUTPUT,62) C1,PRTY 62 FORMAT(40X,'Spin and Parity ',F4.1,1X,A1) IF(ASPIN.EQ.77.777) WRITE(OUTPUT,63) 63 FORMAT(40X,'Spin and Parity UNKNOWN') WRITE(OUTPUT,65) HL,DHL,ITIME 65 FORMAT(40X,'Half-life ',11X,1PE12.5,' +/- ',1PE12.5,2X,A1) ! ! WRITE AVERAGE RADIATION ENERGIES ! 68 IF(OUTPUT.GT.0) THEN WRITE(OUTPUT,'(/31X,A,1PE12.5,A,1PE12.5,A)') & & 'Average LIGHT PARTICLE Energy ',E(1),' +/- ',E(2),' eV' IF(N1.EQ.34) THEN WRITE(OUTPUT,'(34X,A,1PE12.5,A,1PE12.5,A)') & & ' BETA- Energy ',E(7),' +/- ',E(8),' eV' WRITE(OUTPUT,'(34X,A,1PE12.5,A,1PE12.5,A)') & & ' BETA+ Energy ',E(9),' +/- ',E(10),' eV' WRITE(OUTPUT,'(34X,A,1PE12.5,A,1PE12.5,A)') & & ' AUGER ELECTRON Energy ',E(11),' +/- ',E(12),' eV' WRITE(OUTPUT,'(34X,A,1PE12.5,A,1PE12.5,A)') & & 'CONVERSION ELECTRON Energy ',E(13),' +/- ',E(14),' eV' END IF WRITE(OUTPUT,'(/31X,A,1PE12.5,A,1PE12.5,A)') & & 'Average ELECTROMAGNETIC Energy ',E(3),' +/- ',E(4),' eV' IF(N1.EQ.34) THEN WRITE(OUTPUT,'(34X,A,1PE12.5,A,1PE12.5,A)') & & ' GAMMA-RAY Energy ',E(15),' +/- ',E(16),' eV' WRITE(OUTPUT,'(34X,A,1PE12.5,A,1PE12.5,A)') & & ' X-RAY Energy ',E(17),' +/- ',E(18),' eV' WRITE(OUTPUT,'(34X,A,1PE12.5,A,1PE12.5,A)') & & ' BREMSSTRAHLUNG Energy ',E(19),' +/- ',E(20),' eV' WRITE(OUTPUT,'(34X,A,1PE12.5,A,1PE12.5,A)') & & ' ANNILILATION Energy ',E(21),' +/- ',E(22),' eV' END IF WRITE(OUTPUT,'(/31X,A,1PE12.5,A,1PE12.5,A)') & & 'Average HEAVY PARTICLE Energy ',E(5),' +/- ',E(6),' eV' IF(N1.EQ.34) THEN WRITE(OUTPUT,'(34X,A,1PE12.5,A,1PE12.5,A)') & & ' ALPHA PARTICLE Energy ',E(23),' +/- ',E(24),' eV' WRITE(OUTPUT,'(34X,A,1PE12.5,A,1PE12.5,A)') & & ' RECOIL Energy ',E(25),' +/- ',E(26),' eV' WRITE(OUTPUT,'(34X,A,1PE12.5,A,1PE12.5,A)') & & 'SPONTANEOUS FISSION Energy ',E(27),' +/- ',E(28),' eV' WRITE(OUTPUT,'(34X,A,1PE12.5,A,1PE12.5,A)') & & ' NEUTRON Energy ',E(29),' +/- ',E(30),' eV' WRITE(OUTPUT,'(34X,A,1PE12.5,A,1PE12.5,A)') & & ' PROTON Energy ',E(31),' +/- ',E(32),' eV' WRITE(OUTPUT,'(/31X,A,1PE12.5,A,1PE12.5,A)') & & 'Average NEUTRINO Energy ',E(5),' +/- ',E(6),' eV' END IF END IF ! ! WRITE COLUMN HEADINGS ! IF(OUTPUT.GT.0) WRITE(OUTPUT,75) 75 FORMAT(/' Decay Mode Product State',15X,'Q-value (eV)', & & 16X,'Branching Ratio'/) ! ! READ DECAY TYPES AND PRINT ! NPOS = 0 DO 120 I4=1,NDK LFF = B(NPOS+2) NSTTE = 'G' IF(LFF.NE.0) NSTTE = 'M' I3 = B(NPOS+1) ! ! SIMPLE DECAY ! IF((B(NPOS+1)-FLOAT(I3)).NE.0.0) GO TO 100 IC = ' '//NRTYP(I3+1) GO TO 105 ! ! COMPLEX DECAY ! 100 CALL CDECAY(B(NPOS+1),IC) ! ! OUTPUT DECAY MODE PARAMETERS ! 105 IF(OUTPUT.GT.0) WRITE(OUTPUT,110) IC,NSTTE,B(NPOS+3), & & B(NPOS+4),B(NPOS+5),B(NPOS+6) 110 FORMAT(3X,A18,3X,A1,11X,1PE12.5,' +/- ',1PE12.5,5X,1PE12.5, & & ' +/- ',1PE12.5) NPOS = NPOS + 6 120 CONTINUE ! ! OUTPUT SECTION SUMMARY ! WRITE(SOUT,122) MTI,MTBCD,HL,ITIME,NDK,NSP 122 FORMAT(/I6,3X,A30,4X,'Half-life',1PE11.4,1X,A1,5X,I2,' Decay ', & & 'Modes and ',I2,' Radiation Types') ! ! READ ENERGY/INTENSITY AND PRINT ! IF(NSP.EQ.0) GO TO 500 DO 300 I4=1,NSP ! ! READ FIRST LIST RECORD ! CALL CANT(ITAPE,C1,STYP,LCON,L2,N1,NER,MAT,MF,MT,B) I3=STYP+1 IF(OUTPUT.GT.0) WRITE(OUTPUT,125) NSTYP(I3),(B(IJ),IJ=1,6) 125 FORMAT(//6X,'for Decay Radiation Type: ',A16/ & & 10X,'Discrete Spectrum Normalization Factor ',1PE12.5,' +/- ', & & 1PE12.5/ & & 10X,'Average Decay Energy',20X,1PE12.5,' +/- ',1PE12.5,' eV'/ & & 10X,'Continuum Spectrum Normalization Factor ',1PE12.5,' +/- ', & & 1PE12.5) ! ! OUTPUT DISCRETE SPECTRA ! IF(LCON.EQ.1)GO TO 250 IF(STYP.NE.0.0) GO TO 133 IF(OUTPUT.GT.0) WRITE(OUTPUT,130) 130 FORMAT(/' Radiation Relative Mode of ',& & ' Internal Pair Total Internal K-shell InternaL ', & & 'L-shell Internal '/ & & ' Energy Intensity Decay ', & & ' Formation Coeff Conversion Coeff Conversion Coeff ', & & 'Conversion Coeff ') GO TO 150 133 IF(OUTPUT.GT.0.AND.STYP.EQ.1.0) WRITE(OUTPUT,135) 135 FORMAT(/6X,'Radiation Energy',12X,'Relative Intensity',9X, & & 'Mode of Decay Spectrum Definition ') IF(OUTPUT.GT.0.AND.STYP.EQ.2.0) WRITE(OUTPUT,140) 140 FORMAT(/6X,'Radiation Energy',12X,'Relative Intensity',9X, & & 'Mode of Decay Spectrum Definition ', & & 'Positron Intensity') IF(OUTPUT.GT.0.AND.STYP.GE.3.0) WRITE(OUTPUT,145) 145 FORMAT(/6X,'Radiation Energy',12X,'Relative Intensity',9X, & & 'Mode of Decay') ! ! LOOP THROUGH DISCRETE ENERGIES ! 150 DO 200 JJ=1,NER CALL CANT(ITAPE,ER,DER,L1,L2,NT,N2,MAT,MF,MT,B) J3=B(2)+1. ! ! DETERMINE DECAY MODE TEXT ! CALL CDECAY(B(1),IC) ! ! OUTPUT DATA FOR EACH DISCRETE ENERGY ! IF(OUTPUT.EQ.0) GO TO 190 IF(STYP.NE.0.0) GO TO 170 WRITE(OUTPUT,160) ER,B(3),IC,(B(J),J=5,NT,2) 160 FORMAT(2(1X,1PE12.5,5X),1X,A18,4(1X,1PE12.5,5X)) DDER = DER+B(4)+B(6)+B(8)+B(10)+B(12) IF(DDER.NE.0.0) WRITE(OUTPUT,165) DER,(B(J),J=4,NT,2) 165 FORMAT(2(' +/-',1PE12.5,2X),17X,4(:,' +/-',1PE12.5)) GO TO 190 170 IF(STYP.GE.3.) GO TO 185 IF(STYP.EQ.1.0) WRITE(OUTPUT,175) ER,DER,B(3),B(4),IC,NTYP(J3) 175 FORMAT(2(1X,1PE12.5,' +/-',1PE12.5),1X,A18,:,4X,A12,5X,1PE12.5, & & :,' +/-',1PE12.5) IF(STYP.EQ.2.0) WRITE(OUTPUT,175) ER,DER,B(3),B(4),IC,NTYP(J3), & & B(5),B(6) GO TO 190 185 IF(STYP.GE.3.0) WRITE(OUTPUT,175) ER,DER,B(3),B(4),IC 190 DO I=1,12 B(I) = 0. END DO 200 CONTINUE ! ! OUTPUT CONTINUUM SPECTRUM ! 250 IF(LCON.EQ.0) GO TO 300 ! READ THE TAB1 CALL CANT1(ITAPE,RTYP,C2,L1,LCOV,NR,NP,MAT,MF,MT,NBT,INT,X,Y) I3=RTYP+1. IF(OUTPUT.GT.0) WRITE(OUTPUT,260) NRTYP(I3),COV(LCOV+1) 260 FORMAT(//' for Decay Mode: ',A12,1X,A16/ & & 3(' Energy (eV) Continuum Comp. Spectr')/) DO 275 J2=1,NP,3 J3=J2+2 IF(J3.GT.NP) J3 = NP IF(OUTPUT.GT.0) WRITE(OUTPUT,270)(X(J1),Y(J1),J1=J2,J3) 270 FORMAT(6(5X,1PE12.5,5X)) 275 CONTINUE IF(LCOV.EQ.0) GO TO 300 CALL CANT(ITAPE,C1,C2,L1,L2,N1,N2,MAT,MF,MT,Y) 300 CONTINUE ! ! SKIP TO END OF SECTION ! 500 CALL SKPSEC(ITAPE) ! RETURN END ! !*********************************************************************** ! SUBROUTINE CDECAY(FNUM,IC) ! ! ROUTINE TO TRANSLATE A NUMERICAL REPRESENTATION OF A COMPLEX DECAY ! INTO A TEXT STRING ! CHARACTER(LEN=18) IC CHARACTER(LEN=2) ID(6) ! ! STRING FOR EACH DECAY TYPE ! PARAMETER (NDTYPE=11) CHARACTER(LEN=2) ITYPE(NDTYPE) DATA ITYPE/'G','B-','EC','IT','A','N','SF','P',3*'?'/ ! IRTYP = FNUM*100000. N = 0 IC = ' ' DO 25 I=1,6 IR = IRTYP/10 NUM = IRTYP - IR*10 IRTYP = IR IF(NUM.EQ.0) GO TO 25 N = N + 1 ID(N) = ITYPE(NUM+1) 25 CONTINUE IF(N.EQ.0) GO TO 100 ! ! INVERT ORDER AND CENTER IN FIELD ! IBEG = (18-(3*N-1))/2 + 1 DO NN=1,N IC(IBEG:IBEG+1) = ID(N-NN+1) IF(N.EQ.NN) GO TO 100 IC(IBEG+2:IBEG+2) = ',' IBEG = IBEG + 3 END DO ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE9 ! ! ROUTINE TO CONTROL PROCESSING OF BOTH FILES 9 AND 10 ! COMMON DUM(110),NBT(200),INT(200),X(50000),Y(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,DZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) DZABCD COMMON/HEADI/ZAI,AWRI,L1I,L2I,NS,N2I,MATI,MFI,MTI ! CHARACTER(LEN=24) HEAD(2) CHARACTER(LEN=24) UNIT(2) ! DATA HEAD/' Energy Sigma ', & & ' Energy Multiplicity '/ DATA UNIT/' eV Barns ', & & ' eV '/ ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,0,ZAI) ! ! OUTPUT FILE HEADING TO SUMMARY ! CALL FILEHD(MFI) ! ! SET SECTION ID INFORMATION ! 10 CALL HEADIN(0,0,MTI,-1.0) ! ! LOOP THRU ALL OF STATES ! DO 100 I=1,NS CALL TOPAGE CALL CANT1(ITAPE,C1,Q,L1,LFSO,NR,NP,MAT,MF,MT,NBT,INT,X,Y) IF(OUTPUT.GT.0) WRITE(OUTPUT,50) LFSO,Q 50 FORMAT(/' State Number of Final Product ',I2/ & & ' Reaction Q-Value ',1PE11.4,' eV') CALL INTAB(NBT,INT,NR,1,OUTPUT) CALL WRTAB1(OUTPUT,HEAD(11-MF),UNIT(11-MF),X,Y,NP) ! ! OUTPUT SUMMARY LINE ! IF(I.EQ.1) THEN WRITE(SOUT,60) MTI,MTBCD,LFSO,Q,NP,X(1),X(NP),NR 60 FORMAT(/I6,3X,A30,9X,I2,4X,1PE11.4,I6,2X,1PE11.4,1X,1PE11.4,I7) ELSE WRITE(SOUT,70) LFSO,Q,NP,X(1),X(NP),NR 70 FORMAT(48X,I2,4X,1PE11.4,I6,2X,1PE11.4,1X,1PE11.4,I7) END IF ! 100 CONTINUE ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) ! ! SEE IF ANOTHER SECTION IN THE FILE ! CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,NS,N2I,MATI,MFI,MTI) IF(MFI.GT.0)GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE12 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 12 AND FILE 13 ! COMMON DUM(105),EG,ES,LF,NR,NP,NBT(200),INT(200),X(50000),Y(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/HEADI/ZAI,AWRI,LO,LG,NSNK,N2I,MATI,MFI,MTI ! CHARACTER(LEN=11) SLEVEL,GENERG ! CHARACTER(LEN=10) SOURCE(3) CHARACTER(LEN=12) MODE(2) CHARACTER(LEN=24) PROB ! DATA SOURCE/'NOT STATED',' SECONDARY',' PRIMARY '/ DATA MODE/' ALL GAMMA ',' COMPLEX '/ DATA PROB/'TRANSITION PROBABILITY '/ ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,0,ZAI) MBR = MFI - 11 ! ! OUTPUT FILE HEADING TO SUMMARY ! CALL FILEHD(MFI) ! ! SET SECTION IDENTIFICATION INFORMATION ! 10 CALL HEADIN(0,0,MTI,-1.0) ! ! OUTPUT PAGE HEADER ! CALL TOPAGE ! ! BRANCH ON REPRESENTATION ! IF(LO.EQ.2) GO TO 100 ! ! DATA ARE MULTIPLICITIES ! NK=NSNK IF(NK.LE.1) GO TO 25 ! ! READ AND OUTPUT TOTAL PHOTON PRODUCTION ! CALL CANT1(ITAPE,C1,C2,LP,LF,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL LIST12(MBR,1) CALL TOPAGE ! ! PROCESS ALL PARTIAL PHOTON PRODUCTION ! 25 DO 50 N=1,NK CALL CANT1(ITAPE,EG,ES,LP,LF,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL LIST12(MBR,2) ! ! OUTPUT SUMMARY LINE ! SLEVEL = ' CONTINUUM' GENERG = ' ' IF(EG.EQ.0.0) GO TO 30 WRITE(GENERG,27) EG SLEVEL = ' UNKNOWN' IF(ES.NE.0.) WRITE(SLEVEL,27) ES 27 FORMAT(1PE11.4) 30 IF(N.EQ.1) THEN WRITE(SOUT,35) MTI,MTBCD,GENERG,SOURCE(LP+1),SLEVEL,NP, & & X(1),X(NP),NR 35 FORMAT(/I6,3X,A30,1X,A11,3X,A10,2X,A11,I6,3X,1PE11.4,1X, & & 1PE11.4,I7) ELSE WRITE(SOUT,40) GENERG,SOURCE(LP+1),SLEVEL,NP,X(1),X(NP),NR 40 FORMAT(40X,A11,3X,A10,2X,A11,I6,3X,1PE11.4,1X,1PE11.4,I7) END IF ! 50 CONTINUE GO TO 200 ! ! DATA ARE TRANSITION PROBABILITY ARRAYS ! 100 NS=NSNK CALL CANT(ITAPE,ES,C2I,L1I,L2I,NL,NT,MAT,MF,MT,X) ! ! OUTPUT SUMMARY LINE ! WRITE(SOUT,105) MTI,MTBCD,SOURCE(LP+1),ES,NT,MODE(LG),NS 105 FORMAT(/I6,3X,A30,15X,A10,1X,1PE11.4,2X,I4,A12,'Transitions ', & & 'to',I4,' lower levels') ! ! OUT FULL LISTING ! ES=ES*1.0E-6 IF(OUTPUT.GT.0) WRITE(OUTPUT,110) ES,NS 110 FORMAT(/' Transition Probability Array from Level Energy', & & 1PE11.4,' MeV'/ & & ' Number of Levels below the present one, including the ',& & 'ground state = ',I3) IF(OUTPUT.GT.0) WRITE(OUTPUT,120) (PROB,I=1,LG) 120 FORMAT(/' Index Energy ',2(A24)) IF(OUTPUT.GT.0) WRITE(OUTPUT,130) 130 FORMAT(' eV') M=1 DO I=1,NT N=LG+M IF(OUTPUT.GT.0) WRITE(OUTPUT,140) I,(X(II),II=M,N) 140 FORMAT(I5,2X,1PE11.4,2(6X,1PE11.4,5X)) M=N+1 END DO ! ! SKIP SEND RECORD ! 200 CALL SKPREC(ITAPE,1) ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! CALL CONT(ITAPE,ZAI,AWRI,LO,LG,NSNK,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE LIST12(J,K) ! ! ROUTINE TO LIST FILE 12 AND 13 DATA ! COMMON DUM(105),EG,ES,LF,NR,NP,NBT(200),INT(200),X(50000),Y(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/HEADI/ZAI,AWRI,LO,LG,NSNK,N2I,MATI,MFI,MTI ! CHARACTER(LEN=24) HEAD(2) CHARACTER(LEN=24) UNIT(2) ! DATA HEAD/' Energy Photons ', & & ' Energy Sigma '/ DATA UNIT/' eV ', & & ' eV Barns '/ ! ! WRITE TOTAL PHOTON YIELD ! IF(K.EQ.2) GO TO 20 CALL INTAB(NBT,INT,NR,1,OUTPUT) IF(OUTPUT.GT.0.AND.J.EQ.1) WRITE(OUTPUT,10) 10 FORMAT(/' Total Photon Yield') IF(OUTPUT.GT.0.AND.J.EQ.2) WRITE(OUTPUT,15) 15 FORMAT(/' Total Photon Production Cross Section') GO TO 100 ! ! BRANCH ON LF ! 20 IF(LF.NE.1) GO TO 40 ! ! NORMALIZED TABULATED FUNCTION ! IF(OUTPUT.GT.0) WRITE(OUTPUT,30) 30 FORMAT(///' Photon Energy Distribution Law = TABULATED') GO TO 50 ! ! WRITE DISCRETE PHOTON ENERGY TABLE ! 40 IF(OUTPUT.GT.0) WRITE(OUTPUT,45) 45 FORMAT(///' Photon Energy Distribution Law = DISCRETE') ! ! OUTPUT INTERPOLATION SCHEME AND HEADING ! 50 CALL INTAB(NBT,INT,NR,1,OUTPUT) IF(EG.EQ.0.0) GO TO 60 EG=EG*1.0E-6 ES=ES*1.0E-6 IF(OUTPUT.EQ.0) GO TO 100 IF(ES.GT.0.0) WRITE(OUTPUT,55) EG,ES 55 FORMAT(/' Photon Energy',1PE11.4,' MeV, Level Energy', & & 1PE11.4,' MeV') IF(ES.EQ.0.0) WRITE(OUTPUT,57) EG 57 FORMAT(/' Photon Energy',1PE11.4,' MeV, Level Energy UNKNOWN') GO TO 100 60 IF(OUTPUT.GT.0) WRITE(OUTPUT,70) 70 FORMAT(/' Continuous Photon Energy Distribution') ! ! OUTPUT DATA ! 100 CALL WRTAB1(OUTPUT,HEAD(J),UNIT(J),X,Y,NP) ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE14 ! ! ROUTINE TO PROCESS FILE 14 DATA ! COMMON DUM(104),E,NP,NL,LCT,EG,ES,NBT(200),INT(200),P(101), & & FMU(101),PL(81,64),FL(64),TMATRX(4225),DUM1(40264),DUM2(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/HEADI/ZAI,AWRI,LI,LTT,NK,NI,MATI,MFI,MTI ! PARAMETER (NANG=81,NCOF=64) CHARACTER(LEN=11) SLEVEL,GENERG ! CHARACTER(LEN=9) REP(2) DATA REP/'LEGENDRE ','TABULATED'/ ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,0,ZAI) ! ! OUTPUT FILE HEADING TO SUMMARY ! CALL FILEHD(MFI) ! ! SET SECTION IDENTIFICATION INFORMATION ! 10 CALL HEADIN(0,0,MTI,-1.0) ! IF(LI.EQ.1) GO TO 500 ! ! PROCESS ALL SUBSECTIONS WHEN ALL NOT ISOTROPIC ! DO 200 N=1,NK SLEVEL = ' CONTINUUM' GENERG = ' ' ! ! AN ISOTROPIC PHOTON DISTRIBUTION ! IF(N.GT.NI) GO TO 50 CALL CONT(ITAPE,EG,ES,L1,L2,N1,N2,MAT,MF,MT) ES=ES*1.0E-6 EG=EG*1.0E-6 IF(EG.EQ.0.0) GO TO 15 WRITE(GENERG,12) EG SLEVEL = ' UNKNOWN' IF(ES.NE.0.) WRITE(SLEVEL,12) ES 12 FORMAT(1PE11.4) 15 IF(N.EQ.1) CALL TOPAGE IF(OUTPUT.GT.0.AND.EG.NE.0.0) WRITE(OUTPUT,20) EG,ES 20 FORMAT(/6X,1PE12.5,' MeV Photons from the',1PE12.5, & & ' MeV Level are ISOTROPIC') IF(OUTPUT.GT.0.AND.EG.EQ.0.0) WRITE(OUTPUT,30) 30 FORMAT(/6X,'All Photons from the Continuum are ISOTROPIC') ! ! OUTPUT SUMMARY LINE ! IF(N.EQ.1) THEN WRITE(SOUT,25) MTI,MTBCD,GENERG,SLEVEL 25 FORMAT(/I6,3X,A30,1X,A11,1X,A11,42X,'ISOTROPIC') ELSE WRITE(SOUT,27) GENERG,SLEVEL 27 FORMAT(40X,A11,1X,A11,42X,'ISOTROPIC') END IF ! GO TO 200 ! ! NON-ISOTROPIC PHOTON ! 50 CALL CANT2(ITAPE,EG,ES,L1,L2,NR,NE,MAT,MF,MT,NBT,INT) ES=ES*1.0E-6 EG=EG*1.0E-6 IF(EG.EQ.0.0) GO TO 60 WRITE(GENERG,12) EG SLEVEL = ' UNKNOWN' IF(ES.NE.0.0) WRITE(SLEVEL,12) ES 60 NRR = NR NMIN = 100000 NMAX = 0 CALL INTAB(NBT,INT,NR,1,OUTPUT) ! ! DATA IS IN THE FORM OF LEGENDRE COEFFICIENTS ! IF(LTT.GT.1) GO TO 150 ! ! GENERATE TABLES OF LEGENDRE POLYNOMIALS ! CALL LEGEND(PL,NCOF,NANG,1.0,-1.0) DO J=1,NANG P(J) = PL(J,1) END DO ! ! SET UP LOOP OVER ENERGIES ! NP = NANG DO 110 I=1,NE ! ! READ TABLE OF LEGENDRE COEFFICIENTS ! CALL CANT(ITAPE,C1,E,L1,L2,NL,N2,MAT,MF,MT,FL) IF(I.EQ.1) ELO = E IF(I.EQ.NE) EHI = E NMIN = MIN0(NMIN,NL) NMAX = MAX0(NMAX,NL) ! ! RECONSTRUCT AND LIST ANGULAR DISTRIBUTION ! CALL ANGLAR(FMU,FL,PL,NL,NCOF,NANG) CALL TOPAGE CALL LIST4 110 CONTINUE GO TO 170 ! ! DATA IS IN TABULAR FORM ! 150 CONTINUE ! ! SET UP LOOP OVER ENERGIES ! DO 160 I=1,NE ! ! READ TABULATED ANGULAR DISTRIBUTION ! CALL CANT1(ITAPE,C1,E,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,P,FMU) IF(I.EQ.1) ELO = E IF(I.EQ.NE) EHI = E NMIN = MIN0(NMIN,NP) NMAX = MAX0(NMAX,NP) ! ! LIST INTERPOLATION LAW AT TOP OF NEW PAGE ! CALL TOPAGE CALL INTAB(NBT,INT,NR,2,OUTPUT) ! ! LIST TABULAR ANGULAR DISTRIBUTION ! CALL LIST4 160 CONTINUE ! ! OUTPUT SUMMARY LINE ! 170 IF(N.EQ.1) THEN WRITE(SOUT,175) MTI,MTBCD,GENERG,SLEVEL,NE,ELO,EHI,NRR, & & REP(LTT),NMIN,NMAX 175 FORMAT(/I6,3X,A30,1X,A11,1X,A11,I5,3X,1PE11.4,1X,1PE11.4, & & I7,5X,A9,2I5) ELSE WRITE(SOUT,180) GENERG,SLEVEL,NE,ELO,EHI,NRR,REP(LTT),NMIN,NMAX 180 FORMAT(40X,A11,1X,A11,I5,3X,1PE11.4,1X,1PE11.4,I7,5X,A9,2I5) END IF ! 200 CONTINUE GO TO 1000 ! ! DATA IS ISOTROPIC ! 500 CALL TOPAGE IF(OUTPUT.GT.0) WRITE(OUTPUT,510) 510 FORMAT(//6X,'All Photons are ISOTROPIC') WRITE(SOUT,520) MTI,MTBCD 520 FORMAT(/I6,3X,A30,1X,'All Photons are ISOTROPIC') ! ! SKIP SEND RECORD ! 1000 CALL SKPREC(ITAPE,1) ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! CALL CONT(ITAPE,ZAI,AWRI,LI,LTT,NK,NI,MATI,MFI,MTI) IF(MFI.NE.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE15 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 15 ! COMMON DUM(110),NBT(200),INT(200),X(50000),Y(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/HEADI/ZAI,AWRI,L1I,L2I,NC,N2I,MATI,MFI,MTI ! CHARACTER(LEN=24) HEAD(2) CHARACTER(LEN=24) UNIT(2) CHARACTER(LEN=15) LAW ! DATA HEAD/' Energy P(E) ', & & ' Energy Dsigma '/ DATA UNIT/' eV ', & & ' eV 1/eV '/ DATA LAW/'TABULATED(1) '/ ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,0,ZAI) ! ! OUTPUT FILE HEADING TO SUMMARY ! CALL FILEHD(MFI) ! ! SET SECTION IDENTIFICATION INFORMATION ! 10 CALL HEADIN(0,0,MTI,-1.0) ! ! PROCESS ALL SUBSECTIONS ! DO 200 I=1,NC CALL CANT1(ITAPE,C1,C2,L1,LF,NR,NP,MAT,MF,MT,NBT,INT,X,Y) ELO = X(1) EHI = X(NP) NRR = NR NPP = NP NF = 0 ! ! OUTPUT PAGE HEADER ! CALL TOPAGE ! ! OUTPUT INTERPOLATION SCHEME FOR PROBABILITY ! CALL INTAB(NBT,INT,NR,1,OUTPUT) ! ! PRINT TABLE OF PROBABILITIES ! IF(OUTPUT.GT.0) WRITE(OUTPUT,20) 20 FORMAT(10X) CALL WRTAB1(OUTPUT,HEAD(1),UNIT(1),X,Y,NP) ! ! READ AND OUTPUT ENERGY INTERPOLATION ! CALL CANT2(ITAPE,C1,C2,L1,L2,NR,NE,MAT,MF,MT,NBT,INT) CALL TOPAGE CALL INTAB(NBT,INT,NR,1,OUTPUT) ! ! PROCESS TABULAR DISTRIBUTION FOR EACH INCIDENT ENERGY ! DO 150 J1=1,NE CALL CANT1(ITAPE,C1,E,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) NF = MAX0(NF,NP) CALL TOPAGE CALL INTAB(NBT,INT,NR,1,OUTPUT) E=E*1.0E-6 IF(OUTPUT.GT.0) WRITE(OUTPUT,100) E 100 FORMAT(/' Continuous Photon Energy Distribution Neutron Energy', & & 1PE11.4,' MeV') CALL WRTAB1(OUTPUT,HEAD(2),UNIT(2),X,Y,NP) 150 CONTINUE ! ! OUTPUT SUMMARY LINE ! IF(I.EQ.1) THEN WRITE(SOUT,170) MTI,MTBCD,LAW,NPP,ELO,EHI,NRR,NE,NF 170 FORMAT(/I6,3X,A30,2X,A15,I8,4X,1PE11.4,1X,1PE11.4,I7, & & 7X,I3,3X,I3) ELSE WRITE(SOUT,175) LAW,NPP,ELO,EHI,NRR,NE,NF 175 FORMAT(42X,A15,I8,4X,1PE11.4,1X,1PE11.4,I7,7X,I3,3X,I3) END IF ! 200 CONTINUE ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,NC,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE23 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 23 AND FILE 27 DATA ! COMMON DUM(110),NBT(200),INT(200),X(50000),Y(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI ! CHARACTER(LEN=24) HEAD(3) CHARACTER(LEN=24) UNIT(3) ! DATA HEAD/' Energy Sigma ', & & ' Momentum Factor ', & & ' Energy Factor '/ DATA UNIT/' eV Barns ', & & ' 1/Ang ', & & ' eV '/ ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,0,ZAI) ! ! OUTPUT FILE HEADING TO SUMMARY ! CALL FILEHD(MFI) ! ! SET SECTION IDENTIFICATION INFORMATION ! 10 CALL HEADIN(0,0,MTI,-1.0) CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL TOPAGE CALL INTAB(NBT,INT,NR,1,OUTPUT) IHEAD = 1 IF(MFI.EQ.27) THEN IF(MTI.EQ.505.OR.MTI.EQ.506) THEN IHEAD = 3 ELSE IHEAD = 2 END IF END IF CALL WRTAB1(OUTPUT,HEAD(IHEAD),UNIT(IHEAD),X,Y,NP) ! ! OUTPUT SUMMARY LINE ! WRITE(SOUT,50) MTI,MTBCD,NP,X(1),X(NP),NR 50 FORMAT(/I6,3X,A30,7X,I4,2X,1PE11.4,1X,1PE11.4,5X,I3) ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE26 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 26 DATA ! COMMON DUM(86),FL(21),ZAP,NR,NP,NBT(200),INT(200),X(50000), & & Y(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/HEADI/ZAI,AWRI,L1I,LCT,NK,N2I,MATI,MFI,MTI COMMON/SSIX/LANG,NE ! CHARACTER(LEN=24) ZAPBCD CHARACTER(LEN=6) SBCD CHARACTER(LEN=8) ZAPSB ! PARAMETER (NPARTS=2) CHARACTER(LEN=10) OPARTS(NPARTS) INTEGER IPARTS(NPARTS) PARAMETER (NLAWS=9) CHARACTER(LEN=30) LTEXT(NLAWS) CHARACTER(LEN=12) LSTEXT(NLAWS) CHARACTER(LEN=24) HEAD CHARACTER(LEN=24) UNIT ! DATA OPARTS/'PHOTON ','ELECTRON '/ DATA IPARTS/0,11/ ! DATA LTEXT/'UNKNOWN ', & & 'CONTINUUM ENERGY-ANGLE ', & & 'DISCRETE TWO-BODY ', & & 'ISOTROPIC DISCRETE TWO-BODY ', & & 'RECOIL TWO-BODY ', & & 'CHARGED PARTICLE ELASTIC ', & & 'N-BODY PHASE SPACE ', & & 'ANGLE-ENERGY TABULAR ', & & 'ENERGY TRANSFER FOR EXCITATION'/ DATA LSTEXT/'UNKNOWN(0) ','CONTINUUM(1)','DISCRETE(2) ', & & 'ISOTROPIC(3)','RECOIL(4) ','CP ELAST.(5)', & & 'N-BODY(6) ','ANG-EN(7) ','EN-TRANS(8) '/ ! DATA HEAD/' Energy Number '/ DATA UNIT/' eV '/ ! ! SET IDENTIFICATION FOR THE FILE ! 5 CALL HEADIN(MATI,MFI,MTI,ZAI) ! ! SET SECTION IDENTIFICATION INFORMATION ! CALL HEADIN(0,0,MTI,-1.0) ! ! OUTPUT FILE HEADING TO SUMMARY ! CALL FILEHD(MFI) ! ! PROCESS EACH PARTIAL DISTRIBUTION ! DO 190 I=1,NK CALL CANT1(ITAPE,ZAP,C2,LIP,LAW,NR,NP,MAT,MF,MT,NBT,INT,X,Y) NRR = NR NPP = NP ELO = X(1) EHI = X(NP) ! ! OUTPUT PAGE HEADER ! CALL TOPAGE ! ! SET PRODUCT TEXT STRING ! IZAP = ABS(ZAP) + .001 IF(ZAP.LT.0.) IZAP = -IZAP DO 10 J=1,NPARTS IF(IPARTS(J).EQ.IZAP) GO TO 15 10 CONTINUE CALL ZAID(ZAP,ZAPBCD,IERR) CALL NUSYM(ZAP,SBCD,NSBCD,IERR) ZAPSB = SBCD GO TO 20 15 ZAPBCD = OPARTS(J) ZAPSB = OPARTS(J)(1:8) ! ! IDENTIFY DISTRIBUTION ! 20 IF(OUTPUT.GT.0) WRITE(OUTPUT,25) ZAPBCD 25 FORMAT(/' Distribution for ',A24,' Product') ! ! OUTPUT YIELDS ! CALL INTAB(NBT,INT,NR,1,OUTPUT) CALL WRTAB1(OUTPUT,HEAD,UNIT,X,Y,NP) ! ! IDENTIFY THE LAW ! IF(OUTPUT.GT.0) WRITE(OUTPUT,30) LTEXT(LAW+1) 30 FORMAT(/' Product Distribution Law is ',A30) ! ! BRANCH ON LAW ! LF = LAW + 1 LANG = 0 NE = 0 IF(LAW.GT.8) GO TO 200 ! SELECT CASE (LF) ! ! TABULAR FUNCTION ! CASE (2) CALL LIST6A ! ! DISCRETE TWO BODY SCATTERING ! CASE (3) CALL LIST6B ! ! ENERGY TRANSFER FOR EXCITATION ! CASE (9) CALL LIST6E ! END SELECT ! ! OUTPUT SUMMARY LINE ! 175 IF(I.EQ.1) THEN WRITE(SOUT,180) MTI,MTBCD,ZAPSB,LSTEXT(LAW+1),NPP, & & ELO,EHI,NRR,LANG,NE 180 FORMAT(/I6,3X,A30,1X,A8,2X,A12,I8,3X,1PE11.4,1X,1PE11.4,I5, & & 7X,I3,I7) ELSE WRITE(SOUT,185) ZAPSB,LSTEXT(LAW+1),NPP,ELO,EHI,NRR, & & LANG,NE 185 FORMAT(40X,A8,2X,A12,I8,3X,1PE11.4,1X,1PE11.4,I5,7X,I3,I7) END IF ! 190 CONTINUE ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) GO TO 250 ! ! INVALID LAW, SKIP REST OF SECTION ! 200 IF(OUTPUT.GT.0) WRITE(OUTPUT,210) LAW 210 FORMAT(//5X,'LAW = ',I2,' IS ILLEGAL. REST OF SECTION IS SKIPPED') CALL SKPSEC(ITAPE) ! ! CHECK FOR NEW SECTION OR END OF FILE ! 250 CALL CONT(ITAPE,ZAI,AWRI,L1I,LCT,NK,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 5 ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE28 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 28 ! COMMON DUM(110),NBT(200),JINT(200),B(50000),DUM1(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN COMMON/HEADI/ZAI,AWRI,L1I,L2I,NSS,N2I,MATI,MFI,MTI ! ! DEFINE SUBSHELLS ! PARAMETER (NSHELS=39) CHARACTER(LEN=3) SHELL(NSHELS) DATA SHELL/'K ','L1 ','L2 ','L3 ','M1 ','M2 ','M3 ','M4 ','M5 ', & & 'N1 ','N2 ','N3 ','N4 ','N5 ','N6 ','N7 ','O1 ','O2 ', & & 'O3 ','O4 ','O5 ','O6 ','O7 ','O8 ','O9 ','P1 ','P2 ', & & 'P3 ','P4 ','P5 ','P6 ','P7 ','P8 ','P9 ','P10','P11', & & 'Q1 ','Q2 ','Q3 '/ ! CHARACTER(LEN=3) SC,S1,S2 ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,0,ZAI) ! ! OUTPUT FILE HEADING TO SUMMARY ! CALL FILEHD(MFI) ! ! SET SECTION ID INFORMATION ! 10 CALL HEADIN(0,0,MTI,-1.0) ! ! WRITE PAGE LABEL ! CALL TOPAGE ! ! PROCESS EACH SUBSHELL ! DO 50 N=1,NSS ! CALL CANT(ITAPE,SUBI,C2,L1,L2,NW,NTR,MAT,MF,MT,B) IF(N.NE.1) CALL TOPAGE SC = SHELL(INT(SUBI)) IF(N.EQ.1) S1 = SC S2 = SC IF(OUTPUT.GT.0) THEN WRITE(OUTPUT,20) SC,INT(B(2)),B(1) 20 FORMAT(/' Subshell is ',A,' with ',I2,' electrons when ', & & 'neutral.',8X,'Shell binding energy is ',F13.5,' eV') END IF IF(NTR.GT.0) THEN M = 7 NRAD = 0 NONRAD = 0 DO L=1,NTR IF(B(M+1).EQ.0.) THEN NRAD = NRAD + 1 IF(NRAD.EQ.1.AND.OUTPUT.GT.0) THEN WRITE(OUTPUT,'(/3X,A/12X,A,21X,A/6X,2A)') & & 'Radiative transitions','Subshell','Transition', & & 'Secondary Energy ', & & 'Fraction' END IF IF(OUTPUT.GT.0) THEN WRITE(OUTPUT,25) SHELL(INT(B(M))),B(M+2),B(M+3) 25 FORMAT(10X,A,16X,F13.5,8X,F11.8) END IF ELSE NONRAD = NONRAD + 1 IF(NONRAD.EQ.1.AND.OUTPUT.GT.0) THEN WRITE(OUTPUT,'(/3X,A/12X,A,21X,A/6X,2A)') & & 'Non-radiative transitions','Subshell','Transition',& & 'Secondary Tertiary Energy ', & & 'Fraction' END IF IF(OUTPUT.GT.0) THEN WRITE(OUTPUT,30) SHELL(INT(B(M))),SHELL(INT(B(M+1))), & & B(M+2),B(M+3) 30 FORMAT(10X,A,8X,A,5X,F13.5,8X,F11.8) END IF END IF M = M + 6 END DO NONRAD = NTR - NRAD END IF 50 CONTINUE ! ! OUTPUT SECTION INFO TO SUMMARY ! WRITE(SOUT,60) MTI,MTBCD,NSS,S1,S2,NRAD,NONRAD 60 FORMAT(/I6,3X,A30,7X,I4,12X,A,9X,A,12X,I2,16X,I2) ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) ! ! SEE IF ANOTHER SECTION IN FILE 28 ! CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE32 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 32 DATA ! COMMON DUM(510),B(50000),DUM1(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR COMMON/TOPR/EMAX,ELIS,STA,LIS,LISO COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI ! CHARACTER(LEN=120) LINE ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,0,ZAI) ! ! OUTPUT FILE HEADING TO SUMMARY ! CALL FILEHD(MFI) ! ! SET SECTION IDENTIFICATION INFORMATION ! 10 CALL HEADIN(0,0,MTI,-1.0) CALL TOPAGE IF(OUTPUT.GT.0) WRITE(OUTPUT,15) 15 FORMAT(//' ****COVARIANCE DATA EXISTS BUT IS NOT LISTED****') ! ! ENDF-5 FORMAT ! IF(NFOR.GT.5) GO TO 50 ! ! OUTPUT SUMMARY LINE ! WRITE(SOUT,20) MTI,MTBCD 20 FORMAT(/I6,3X,A30,4X,'Covariances for Resolved Resonance Region', & & ' BREIT-WIGNER Parameters are given.'/ & & 58X,'(SEE SUMMARY FOR FILE 2)') ! ! SKIP REST OF SECTION ! CALL SKPSEC(ITAPE) GO TO 500 ! ! ENDF-6 FORMAT ! 50 NIS = N1I WRITE(SOUT,51) 51 FORMAT(' ') WRITE(LINE,52) MTI,MTBCD 52 FORMAT(I6,3X,A30) LINELN = 39 ! ! LOOP OVER ISOTOPES ! DO 200 I=1,NIS CALL CONT(ITAPE,ZAI,ABN,L1,LFW,NER,N2,MATI,MFI,MTI) IZAI = IFIX(ZAI+.00001) IZ = IZAI/1000 IA = MOD(IZAI,1000) WRITE(LINE(42:48),55) IZ,IA 55 FORMAT(I2,2X,I3) ! ! LOOP OVER ENERGY RANGES ! DO 190 II=1,NER CALL CONT(ITAPE,EL,EH,LRU,LRF,NRO,NAPS,MATI,MFI,MTI) WRITE(LINE(53:79),57) EL,EH,LRF 57 FORMAT(1PE11.4,1X,1PE11.4,2X,I2) ! ! RESOLVED RESONANCE RANGE ! IF(LRU.EQ.2) GO TO 125 LINE(84:93) = ' Resolved ' LINELN = 93 !*****ENERGY DEPENDENT SCATTERING LENGTH IF(NRO.GT.0) THEN CALL CONT(ITAPE,C1,C2,L1,L2,N1,NIT,MATI,MFI,MTI) DO 60 I2=1,NIT CALL CANT(ITAPE,C1,C2,L1,L2,N1,NIT,MATI,MFI,MTI,B) 60 CONTINUE END IF !*****L-STATE CONTROL RECORD CALL CONT(ITAPE,C1,C2,L1,LCOMP,NLS,N2,MATI,MFI,MTI) ! ! SINGLE AND MULTILEVEL BREIT-WIGNER ENDF-5 STYLE ! IF(LCOMP.EQ.1) GO TO 80 WRITE(LINE(99:100),65) NLS 65 FORMAT(I2) LINELN = 100 DO 75 N=1,NLS CALL CANT(ITAPE,C1,C2,L1,L2,N1,N2,MATI,MFI,MTI,B) 75 CONTINUE GO TO 180 ! ! NEW STYLE FORMATS ! 80 CALL CONT(ITAPE,C1,C2,L1,L2,NSRS,NLRS,MATI,MFI,MTI) WRITE(LINE(109:117),85) NSRS,NLRS 85 FORMAT(I3,3X,I3) LINELN = 117 IF(NSRS.EQ.0) GO TO 100 DO 90 I2=1,NSRS CALL CANT(ITAPE,C1,C2,L1,L2,N1,N2,MATI,MFI,MTI,B) 90 CONTINUE 100 IF(NLRS.EQ.0) GO TO 180 DO 110 I2=1,NLRS CALL CANT(ITAPE,C1,C2,L1,L2,N1,N2,MATI,MFI,MTI,B) 110 CONTINUE GO TO 180 ! ! UNRESOLVED RESONANCE PARAMETERS ! 125 LINE(84:93) = 'Unresolved' CALL CONT(ITAPE,C1,C2,L1,L2,NLS,N2,MATI,MFI,MTI) WRITE(LINE(99:100),65) NLS LINELN = 100 DO 150 N=1,NLS CALL CONT(ITAPE,C1,C2,L1,L2,NJS,N2,MATI,MFI,MTI) DO NN=1,NJS CALL CANT(ITAPE,C1,C2,L1,L2,N1,N2,MATI,MFI,MTI,B) END DO 150 CONTINUE CALL CANT(ITAPE,C1,C2,L1,L2,N1,N2,MATI,MFI,MTI,B) ! ! OUTPUT SUMMARY LINE ! 180 WRITE(SOUT,185) LINE(1:LINELN) 185 FORMAT(A) LINE = ' ' LINELN = 1 ! 190 CONTINUE 200 CONTINUE ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! 500 CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE33 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 31 AND 33 DATA ! COMMON DUM(110),NBT(200),INT(200),B(50000),DUM1(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/HEADI/ZAI,AWRI,L1I,MTL,N1I,NL,MATI,MFI,MTI ! CHARACTER(LEN=125) LINE ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,0,ZAI) ! ! OUTPUT FILE HEADING TO SUMMARY ! CALL FILEHD(MFI) ! ! SET SECTION IDENTIFICATION INFORMATION ! 10 CALL HEADIN(0,0,MTI,-1.0) CALL TOPAGE IF(OUTPUT.GT.0) WRITE(OUTPUT,12) 12 FORMAT(//' ****COVARIANCE DATA EXISTS BUT IS NOT LISTED****') WRITE(SOUT,13) 13 FORMAT(' ') WRITE(LINE,14) MTI,MTBCD 14 FORMAT(I6,3X,A30) LINELN = 39 ! ! PROCESS ALL SUBSECTIONS ! IF(MTL.NE.0) GO TO 300 DO 100 N=1,NL CALL CONT(ITAPE,C1,C2,MAT1,MT1,NC,NI,MAT,MF,MT) WRITE(LINE(42:52),15) MAT1,MT1 15 FORMAT(I4,4X,I3) IF(MAT1.EQ.0) LINE(42:45) = 'SELF' LINELN = 45 ! ! PROCESS ALL SUB-SUBSECTIONS ! NS = NC + NI DO 90 NN=1,NS IF(NN.LE.NC) CALL CONT(ITAPE,C1,C2,L1,LTY,N1,N2,MAT,MF,MT) CALL CANT(ITAPE,E1,E2,MATS,MTS,N2E,NE,MAT,MF,MT,B) ! ! NC TYPE SUB-SUBSECTIONS ! IF(NN.LE.NC) THEN WRITE(LINE(57:107),20) E1,E2,LTY,NE 20 FORMAT(1PE11.4,1X,1PE11.4,6X,'NC',8X,I2,7X,I3) LINELN = 107 IF(MATS.NE.0.OR.MTS.NE.0) THEN WRITE(LINE(113:122),25) MATS,MTS 25 FORMAT(I4,3X,I3) LINELN = 122 END IF ! ! NI TYPE SUB-SUBSECTIONS ! ELSE E1 = B(1) E2 = B(N2E-1) IF(LTY.EQ.5.OR.LTY.EQ.6) E2 = B(NE) LTY = MTS WRITE(LINE(57:107),30) E1,E2,LTY,NE 30 FORMAT(1PE11.4,1X,1PE11.4,6X,'NI',8X,I2,7X,I3) LINELN = 107 END IF ! ! OUTPUT SUMMARY LINE ! WRITE(SOUT,50) LINE(1:LINELN) 50 FORMAT(A) LINE = ' ' LINELN = 1 ! 90 CONTINUE 100 CONTINUE GO TO 400 ! ! LUMPED COVARIANCES ! 300 WRITE(LINE(49:86),310) MTL 310 FORMAT('Component of Lumped Reaction MTL =',I4) WRITE(SOUT,50) LINE(1:86) ! ! SKIP SEND RECORD ! 400 CALL SKPREC(ITAPE,1) ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! CALL CONT(ITAPE,ZAI,AWRI,L1I,MTL,N1I,NL,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE34 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 34 DATA ! COMMON DUM(510),B(50000),DUM1(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,0,ZAI) ! ! OUTPUT FILE HEADING TO SUMMARY ! CALL FILEHD(MFI) ! ! SET SECTION IDENTIFICATION INFORMATION ! 10 CALL HEADIN(0,0,MTI,-1.0) CALL TOPAGE IF(OUTPUT.GT.0) WRITE(OUTPUT,20) 20 FORMAT(//' ****COVARIANCE DATA EXISTS BUT IS NOT LISTED****') ! ! LOOP OVER SUBSECTIONS ! NMT1 = N2I DO 100 N=1,NMT1 CALL CONT(ITAPE,C1,C2,MAT1,MT1,NL,NL1,MAT,MF,MT) NSS = NL*NL1 ! ! LOOP OVER ALL SUB-SUBSECTIONS ! DO 90 NN=1,NSS CALL CONT(ITAPE,C1,C2,L,L1,N1,NI,MAT,MF,MT) ! ! LOOP OVER ALL SUB-SUB-SUBSECTIONS ! DO 80 NNN=1,NI CALL CANT(ITAPE,C1,C2,LS,LB,NT,NE,MAT,MF,MT,B) ! ! OUTPUT SUMMARY LINE ! IF(NNN.GT.1) GO TO 70 IF(N.EQ.1) THEN WRITE(SOUT,50) MTI,MTBCD,MT1,L,L1,LB,NE 50 FORMAT(/I6,3X,A30,5X,'SELF',I7,6X,I2,I5,9X,'NI',8X,I2,7X,I3) ELSE IF(NN.EQ.1) THEN WRITE(SOUT,55) MT1,L,L1,LB,NE 55 FORMAT(44X,'SELF',4X,I7,6X,I2,I5,9X,'NI',8X,I2,7X,I3) ELSE WRITE(SOUT,60) L,L1,LB,NE 60 FORMAT(61X,I2,I5,9X,'NI',8X,I2,7X,I3) END IF END IF GO TO 90 70 WRITE(SOUT,75) L,L1,LB,NE 75 FORMAT(61X,I2,I3,6X,'NI',8X,I2,7X,I3) 80 CONTINUE 90 CONTINUE 100 CONTINUE ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE35 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 35 DATA ! COMMON DUM(510),B(50000),DUM1(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,0,ZAI) ! ! OUTPUT FILE HEADING TO SUMMARY ! CALL FILEHD(MFI) ! ! SET SECTION IDENTIFICATION INFORMATION ! 10 CALL HEADIN(0,0,MTI,-1.0) CALL TOPAGE IF(OUTPUT.GT.0) WRITE(OUTPUT,20) 20 FORMAT(//' ****COVARIANCE DATA EXISTS BUT IS NOT LISTED****') ! ! LOOP OVER SUBSECTIONS ! NK = N1I DO 100 N=1,NK CALL CANT(ITAPE,E1,E2,L1,L2,NT,NE,MAT,MF,MT,B) IF(N.EQ.1) THEN WRITE(SOUT,50) MTI,MTBCD,E1,E2,NE 50 FORMAT(/I6,3X,A30,4X,1PE11.4,1X,1PE11.4,7X,I3) ELSE WRITE(SOUT,80) E1,E2,NE 80 FORMAT(43X,1PE11.4,1X,1PE11.4,7X,I3) END IF 100 CONTINUE ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE40 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 40 DATA ! COMMON DUM(110),NBT(200),INT(200),B(50000),DUM1(50000) COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,NS,MATI,MFI,MTI ! CHARACTER(LEN=4) CMAT1 CHARACTER(LEN=10) STAN CHARACTER(LEN=2) SSTYPE ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,0,ZAI) ! ! OUTPUT FILE HEADING TO SUMMARY ! CALL FILEHD(MFI) ! ! SET SECTION IDENTIFICATION INFORMATION ! 10 CALL HEADIN(0,0,MTI,-1.0) CALL TOPAGE IF(OUTPUT.GT.0) WRITE(OUTPUT,12) 12 FORMAT(//' ****COVARIANCE DATA EXISTS BUT IS NOT LISTED****') ! ! PROCESS ALL SUBSECTIONS ! DO 100 N=1,NS CALL CONT(ITAPE,C1,C2,L1,LFS,N1,NL,MAT,MF,MT) ! ! PROCESS ALL SUB-SUBSECTIONS ! DO 95 NN=1,NL CALL CONT(ITAPE,XMF1,XLFS1,MAT1,MT1,NC,NI,MAT,MF,MT) MF1 = IFIX(XMF1+.00001) LFS1 = IFIX(XLFS1+.00001) ! ! PROCESS ALL SUB-SUB-SUBSECTIONS ! NS = NC + NI DO 90 NNN=1,NS IF(NNN.LE.NC) CALL CONT(ITAPE,C1,C2,L1,LTY,N1,N2,MAT,MF,MT) CALL CANT(ITAPE,E1,E2,MATS,MTS,N2E,NE,MAT,MF,MT,B) SSTYPE = 'NC' CMAT1 = 'SELF' IF(MAT1.NE.0) WRITE(CMAT1,15) MAT1 15 FORMAT(I4) STAN = ' ' IF(MATS.EQ.0.AND.MTS.EQ.0) GO TO 30 WRITE(STAN,20) MATS,MTS 20 FORMAT(I4,3X,I3) ! ! SET UP FOR NI TYPE SUB-SUBSECTION ! 30 IF(NNN.LE.NC) GO TO 40 SSTYPE = 'NI' E1 = B(1) E2 = B(N2E-1) LTY = MTS MATS = 0 MTS = 0 STAN = ' ' IF(LTY.EQ.5.OR.LTY.EQ.6) E2 = B(NE) ! ! OUTPUT SUMMARY LINE ! 40 IF(NNN.GT.1) GO TO 70 IF(N.EQ.1) THEN WRITE(SOUT,50) MTI,MTBCD(1:26),LFS,CMAT1,MF1,MT1, & & LFS1,E1,E2,SSTYPE,LTY,NE,STAN 50 FORMAT(/I6,3X,A26,I4,4X,A4,2I4,I5,5X,1PE11.4,1X,1PE11.4, & & 6X,A2,8X,I2,7X,I3,5X,A10) ELSE IF(NN.EQ.1) WRITE(SOUT,55) LFS,CMAT1,MF1,MT1,LFS1,E1,E2, & & SSTYPE,LTY,NE,STAN 55 FORMAT(36X,I3,4X,A4,4X,2I4,I5,5X,1PE11.4,1X,1PE11.4,6X,A2, & & 8X,I2,7X,I3,5X,A10) IF(NN.GT.1) WRITE(SOUT,60) CMAT1,MF1,MT1,LFS1,E1,E2,SSTYPE, & & LTY,NE,STAN 60 FORMAT(43X,A4,4X,2I4,I5,5X,1PE11.4,1X,1PE11.4,6X,A2,8X,I2, & & 7X,I3,5X,A10) END IF GO TO 90 70 WRITE(SOUT,80) E1,E2,SSTYPE,LTY,NE,STAN 80 FORMAT(65X,1PE11.4,1X,1PE11.4,6X,A2,8X,I2,7X,I3,5X,A10) 90 CONTINUE 95 CONTINUE 100 CONTINUE ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE TOPAGE ! ! ROUTINE TO OUTPUT TOP OF PAGE HEADING ! COMMON/INDAT/IOPT,NLABEL,EDITIT,IFULL INTEGER EDITIT COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR ! ! SKIP IF FULL LISTING NOT REQUIRED ! IF(OUTPUT.EQ.0) GO TO 100 ! ! EITHER SKIP 4 LINES OR TO TOP OF NEXT PAGE ! IF(EDITIT.NE.1) WRITE(OUTPUT,10) 10 FORMAT(////) IF(EDITIT.EQ.1) WRITE(OUTPUT,20) 20 FORMAT('1') ! ! WRITE IDENTIFICATION ! WRITE(OUTPUT,50) ZABCD,MATIN,NSUB,LIBBCD,NREL,MTBCD,MFBCD 50 FORMAT(6X,A24,8X,' Material No.',I5,3X,' Sub-library No. ',I6, & & 12X,A14,' Release No. ',I2//45X,A30/36X,A48/) ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE FILEHD(MFH) ! ! ROUTINE TO OUTPUT TOP OF PAGE HEADING ! COMMON/INDAT/IOPT,NLABEL,EDITIT,IFULL INTEGER EDITIT COMMON/IODATA/INPUT,OTPUT,ITAPE,SOUT,OUTPUT INTEGER OTPUT,SOUT,OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR ! CHARACTER(LEN=7) SEC CHARACTER(LEN=13) RTYP ! DATA SEC/'Section'/ DATA RTYP/'Reaction Type'/ ! ! EITHER SKIP 4 LINES OR TO TOP OF NEXT PAGE ! IF(EDITIT.EQ.1) THEN WRITE(SOUT,10) 10 FORMAT('1') ELSE WRITE(SOUT,15) 15 FORMAT(////) END IF ! ! WRITE IDENTIFICATION ! WRITE(SOUT,20) ZABCD,MATIN,NSUB,LIBBCD,NREL,MFH,MFBCD 20 FORMAT(6X,A24,8X,' Material No.',I5,3X,' Sub-library No. ',I6, & & 12X,A14,' Release No. ',I2//55X,'File# ',I3/36X,A48/) ! ! OUTPUT SUMMARY TABLE HEADINGS ! SELECT CASE (MFH) ! !*****FILES 1 AND 2 ! CASE (1,2) WRITE(SOUT,35) SEC,RTYP 35 FORMAT(1X,A7,9X,A13/3X,'(MT)'/1X,7('-'),8X,15('-')) ! !****FILE 3 ! CASE (3) IF(NFOR.GE.6) THEN WRITE(SOUT,65) SEC,RTYP 65 FORMAT(1X,A7,9X,A13,24X,' Reaction Intermediate Energy', & & ' Energy range(eV)',' Interp.'/ & & 54X,' Q-value Q-value Points',27X,'Regions'/ & & 2X,'(MT)',75X,'(NP) from to (NR)'/, & & 1X,7('-'),8X,15('-'),24X,8('-'),6X,8('-'),4X,4('-'), & & 5X,4('-'),10X,4('-'),6X,4('-')) ELSE WRITE(SOUT,70) SEC,RTYP 70 FORMAT(1X,A7,9X,A13,24X,'Reaction Energy ', & & 'Energy range(eV) Interp.'/ & & 54X,'Q-value Points',27X,'Regions'/ & & 2X,'(MT)',61X,'(NP) from to (NR)'/, & & 1X,7('-'),8X,15('-'),23X,8('-'),5X,4('-'),5X,4('-'), & & 10X,4('-'),6X,4('-')) END IF ! !*****FILE 4 ! CASE (4) WRITE(SOUT,85) SEC,RTYP 85 FORMAT(1X,A7,9X,A13,10X,' Reference Energy Energy ', & & 'range(eV) Interp. Data Angular points-NP'/ & & 43X,'Frame Points',27X,'Regions Form ', & & 'or Order-NL'/ & & 2X,'(MT)',34X,' (LCT) (NE) from ', & & 'to (NR) (LTT) MIN MAX'/ & & 1X,7('-'),8X,15('-'),12X,5('-'),4X,4('-'),6X,4('-'), & & 10X,4('-'),5X,4('-'),3X,9('-'),3X,3('-'),5X,3('-')) ! !*****FILE 5 ! CASE (5) WRITE(SOUT,95) SEC,RTYP 95 FORMAT(1X,A7,9X,A13,13X,'Distribution Incident ', & & 'Energy range(eV) Interp. Points for Cutoff'/ & & 47X,'Law',8X,'Energies',24X,'Regions Emitted Energy'/, & & 100X,'Function (eV)'/ & & 2X,'(MT)',41X,'(LF)',9X,'(NP) from to ', & & ' (NR) (NE) (NF) (U)'/ & & 1X,7('-'),8X,15('-'),16X,4('-'),9X,4('-'),5X,4('-'),10X,4('-'),& & 5X,4('-'),3X,4('-'),2X,4('-'),4X,8('-')) ! !*****FILE 6 ! CASE (6) WRITE(SOUT,105) SEC,RTYP 105 FORMAT(1X,A7,9X,A13,10X,'Outgoing Energy-Angle Energy ', & & 'Energy range(eV) Interp.',4X,'Emitted '/ & & 40X,'Particle Model Points',26X,'Regions',3X, & & 'Function'/ & & 53X,'(LAW) (NP) from to (NR) ', & & '(LANG) (NE)'/ & & 1X,7('-'),8X,15('-'),9X,8('-'),2X,12('-'),4X,4('-'),6X,4('-'), & & 10X,4('-'),4X,4('-'),4X,6('-'),2X,4('-')) ! !*****FILE 8 ! CASE (8) WRITE(SOUT,125) SEC,RTYP 125 FORMAT(1X,A7,9X,A13,18X,'Product',9X,'Final Excitation',10X, & & 'Data',11X,'Decay'/48X,'Nuclide State ', & & 'Energy Representation Modes'/ & & 64X,'Flags'/2X,'(MT)',37X,'(ZAP) (MATP) (LFS)', & & 7X,'(ELFS) (LMF) (ND)'/ & & 1X,7('-'),8X,15('-'),12X,5('-'),6X,6('-'),4X,5('-'),7X,6('-'), & & 11X,5('-'),11X,4('-')) ! !*****FILES 9 AND 10 ! CASE (9,10) WRITE(SOUT,135) SEC,RTYP 135 FORMAT(1X,A7,9X,A13,16X,'Final Reaction Energy ', & & 'Energy range(eV) Interp.'/ & & 43X,' State Flag Q-value Points',27X,'Regions'/ & & 2X,'(MT)',40X,'(LFS)',16X,'(NP) from to', & & 7X,'(NR)'/ & & 1X,7('-'),8X,15('-'),15X,5('-'),5X,8('-'),3X,4('-'), & & 5X,4('-'),10X,4('-'),6X,4('-')) ! !*****FILES 12 AND 13 ! CASE (12,13) WRITE(SOUT,175) SEC,RTYP 175 FORMAT(1X,A7,9X,A13,13X,'Photon Photon Source ', & & 'Energy Energy range(eV) Interp.'/ & & 43X,'Energy Origin Level Points',27X,'Regions'/& & 43X,'(MeV) (MeV)'/ & & 2X,'(MT)',38X,'(EG) (LP) (ES) (NP)', & & 5X,'from to (NR)'/ & & 1X,7('-'),8X,15('-'),13X,4('-'),9X,4('-'),9X,4('-'),6X,4('-'), & & 5X,4('-'),10X,4('-'),6X,4('-')) ! !*****FILE 14 ! CASE (14) WRITE(SOUT,185) SEC,RTYP 185 FORMAT(1X,A7,9X,A13,13X,'Photon Source Energy ', & & 'Energy range(eV) Interp. Data Angular'/ & & 43X,'Energy Level Points',27X,'Regions Form ', & & 'Momentum-NL'/43X,'(MeV)',7X,'(MeV)',55X,'or Points-NP'/ & & 2X,'(MT)',38X,'(EG) (ES) (NE) from',11X, & & 'to',7X,'(NR) (LTT) MIN MAX'/ & & 1X,7('-'),8X,15('-'),13X,4('-'),8X,4('-'),5X,4('-'),5X,4('-'), & & 10X,4('-'),6X,4('-'),6X,5('-'),4X,3('-'),2X,3('-')) ! !*****FILE 15 ! CASE (15) WRITE(SOUT,195) SEC,RTYP 195 FORMAT(1X,A7,9X,A13,13X,'Distribution Incident ', & & 'Energy range(eV) Interp. Points for'/ & & 47X,'Law Energies',27X,'Regions Emitted'/ & & 106X,'Function'/ & & 2X,'(MT)',41X,'(LF)',10X,'(NP) from to',7X, & & '(NR) (NE) (NF)'/ & & 1X,7('-'),8X,15('-'),16X,4('-'),10X,4('-'),6X,4('-'), & & 10X,4('-'),6X,4('-'),6X,4('-'),2X,4('-')) ! !*****FILES 23 AND 27 ! CASE (23,27) WRITE(SOUT,255) SEC,RTYP 255 FORMAT(1X,A7,9X,A13,15X,'Energy Energy range(eV) ', & & 'Interp.'/45X,'Points',27X,'Regions'/ & & 2X,'(MT)',40X,'(NP) from to (NR)'/ & & 1X,7('-'),8X,15('-'),15X,4('-'),5X,4('-'),10X,4('-'),6X,4('-')) ! !*****FILE 26 ! CASE (26) WRITE(SOUT,265) SEC,RTYP 265 FORMAT(1X,A7,9X,A13,10X,'Outgoing Energy-Angle Energy ', & & 'Energy range(eV) Interp.',4X,'Emitted '/ & & 40X,'Particle Model Points',26X,'Regions',3X, & & 'Function'/ & & 53X,'(LAW) (NP) from to (NR) ', & & '(LANG) (NE)'/ & & 1X,7('-'),8X,15('-'),9X,8('-'),2X,12('-'),4X,4('-'),6X,4('-'), & & 10X,4('-'),4X,4('-'),4X,6('-'),2X,4('-')) ! !*****FILE 28 ! CASE (28) WRITE(SOUT,275) SEC,RTYP 275 FORMAT(1X,A7,9X,A13,15X,'Number of Subshell range ', & & ' Number of transitions'/45X,'Subshells'/ & & 2X,'(MT)',41X,'(NSS)',9X,'from to ', & & 'Radiative Non-radiative'/ & & 1X,7('-'),8X,15('-'),16X,5('-'),9X,4('-'),8X,4('-'),6X, & & 13('-'),5X,13('-')) ! !*****FILES 31 AND 33 ! CASE (31,33) WRITE(SOUT,315) SEC,RTYP 315 FORMAT(1X,A7,9X,A13,9X,'Covariance with',6X,'Energy range(eV)', & & 8X,'Sub- LTY Energy Standard'/ & & 81X,'Subsection or Points'/ & & 2X,'(MT)',35X,'MAT1 MT1',7X,'from to',8X,'Type', & & 7X,'LB',15X,'MATS MTS'/ & & 1X,7('-'),8X,15('-'),10X,4('-'),4X,3('-'),7X,4('-'),10X,4('-'), & & 7X,4('-'),7X,3('-'),5X,4('-'),5X,4('-'),3X,3('-')) ! !*****FILE 32 ! CASE (32) IF(NFOR.LT.6) THEN WRITE(SOUT,35) SEC,RTYP ELSE WRITE(SOUT,325) SEC,RTYP 325 FORMAT(1X,A7,9X,A13,11X,'Isotope',8X,'Energy range(eV)',5X, & & 'LRF',5X,'Region',8X,'L',8X,'NSRS NLRS'/ & & 42X,'Z A',8X,'from to',14X,'type',6X,'values'/ & & 1X,7('-'),8X,15('-'),10X,'-- ---',7X,4('-'),10X,4('-'), & & 4X,3('-'),3X,10('-'),5X,'--',8X,'---- ----') END IF ! !*****FILE 34 ! CASE (34) WRITE(SOUT,355) SEC,RTYP 355 FORMAT(1X,A7,9X,A13,12X,'Covariance with',4X,'L L1', & & 6X,'Sub-Sub- LB Energy'/ & & 73X,'Subsection Points'/ & & 2X,'(MT)',38X,'MAT1 MT1',21X,'Type'/ & & 1X,7('-'),8X,15('-'),13X,4('-'),4X,3('-'),6X,'-- --', & & 8X,4('-'),7X,2('-'),6X,4('-')) ! !*****FILE 35 ! CASE (35) WRITE(SOUT,365) SEC,RTYP 365 FORMAT(1X,A7,9X,A13,16X,'Energy range(eV)',8X,'Energy'/ & & 70X,'Points'/2X,'(MT)',39X,'from to'/ & & 1X,7('-'),8X,15('-'),14X,4('-'),10X,4('-'),6X,4('-')) ! !*****FILE 40 ! CASE (40) WRITE(SOUT,405) SEC,RTYP 405 FORMAT(1X,A7,9X,A13,14X,'Covariance with',10X,'Energy range(eV)', & & 6X,'Sub-Sub- LTY Energy Standard'/ & & 90X,'Subsection or Points'/ & & 2X,'(MT)',30X,'LFS',4X,'MAT1 MF1 MT1 LFS1',8X, & & 'from to',8X,'Type',7X,'LB',15X,'MATS MTS'/ & & 1X,7('-'),8X,15('-'),5X,3('-'),4X,4('-'),2(1X,3('-')),1X,4('-'),& & 8X,4('-'),10X,4('-'),7X,4('-'),7X,3('-'),5X,4('-'),5X,4('-'), & & 3X,3('-')) ! END SELECT ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE INTAB(NBT,INT,NR,NTYPE,OUTPUT) ! ! LIST AN INTERPOLATION LAW, INTERPRETING THE RANGE AND TYPE OF LAW. ! ! NBT =TABLE OF INTERPOLATION LAW BOUNDARIES ! INT =TABLE OF INTERPOLATION LAW CODES DEFINED AS FOLLOWS.. ! =1 CONSTANT FROM THE LOWER LIMIT ! 2 Y LINEAR IN X ! 3 Y LINEAR IN LN X ! 4 LN Y LINEAR IN X ! 5 LN Y LINEAR IN LN X ! 6 COULOMB THRESHOLD ! NR =NUMBER OF RANGES OR POINTS IN NBT AND INT TABLES ! NTYPE =INTERPOLATION DESCRIPTION INDICATOR DEFINED AS FOLLOWS... ! 1 INTERPOLATION LAW BETWEEN ENERGIES ! 2 INTERPOLATION LAW BETWEEN COSINES ! 3 INTERPOLATION LAW BETWEEN TEMPERATURES ! 4 INTERPOLATION LAW BETWEEN BETAS (THERMAL SCATTERING LAW) ! 5 INTERPOLATION LAW BETWEEN ALPHAS(THERMAL SCATTERING LAW) ! 6 INTERPLOATION LAW BETWEEN VALUES OF X ! OUTPUT=INTEGER LOGICAL NUMBER OF OUTPUT FILE ! INTEGER NBT(NR),INT(NR),OUTPUT ! INTEGER NBTF(201) CHARACTER(LEN=12) ARRAY(6) CHARACTER(LEN=21) HEAD CHARACTER(LEN=19) BCD(7) ! ! DEFINE INTERPRETATIONS ! DATA ARRAY/'Energies ','Cosines ', & & 'Temperatures','Betas ', & & 'Alphas ','Values of X '/ ! ! DEFINE TABLE HEADINGS ! DATA HEAD/'Range Description'/ ! ! DEFINE ALPHANUMERIC EQUIVALENT OF INTERPOLATION CODES ! DATA BCD /'CONSTANT ', & & 'Y LINEAR IN X ', & & 'Y LINEAR IN LN X ', & & 'LN Y LINEAR IN X ', & & 'LN Y LINEAR IN LN X', & & 'COULOMB THRESHOLD ', & & '******(ERROR)******'/ ! ! SKIP IF FULL FILE NOT REQUESTED ! IF(OUTPUT.EQ.0) GO TO 200 ! ! WRITE TABLE HEADING ! WRITE(OUTPUT,10) ARRAY(NTYPE) 10 FORMAT(/' Interpolation Law between ',A12) NNR = MIN0(NR,3) WRITE(OUTPUT,20) (HEAD,I=1,NNR) 20 FORMAT(3(5X,A21,13X)) ! ! IF IN ERROR, SET INTERPOLATION CODE TO 7 ! NBTF(1) = 1 DO 50 I=1,NR NBTF(I+1) = NBT(I) INT(I) = MOD(INT(I),10) IF(INT(I).GT.6.OR.INT(I).LT.1) INT(I) = 7 50 CONTINUE DO 100 I=1,NR,3 IU = MIN0(I+2,NR) WRITE(OUTPUT,75) (NBTF(J),NBTF(J+1),BCD(INT(J)),J=I,IU) 75 FORMAT(3(I5,' TO',I5,2X,A19,5X)) 100 CONTINUE ! 200 RETURN END ! !*********************************************************************** ! SUBROUTINE GETLIM(XMIN,XMAX,X,Y,NP) ! ! ROUTINE TO GET X LIMITS FROM A TAB1 RECORD ! COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN ! REAL X(NP),Y(NP) ! ! INITIALIZE MINIMUM X VALUE ! XMIN = X(1) ! ! SET MAXIMUM X VALUE WHEN NO PAGING ! IF(NCONT.GT.0) GO TO 20 XMAX = X(NP) GO TO 100 ! ! READ ALL PAGES ! 20 IF(NB.EQ.NN) GO TO 50 CALL RDTAB(X,Y) GO TO 20 ! ! SET MAXIMUM X VALUE WHEN LAST PAGE HAS BEEN READ ! 50 NU = NB - NA + 1 XMAX = X(NU) ! ! RESTORE INITIAL PAGE IN CORE ! CALL RDTAB(X,Y) ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE WRTAB1(OUTPUT,HEAD,UNIT,X,Y,NP) ! ! ROUTINE TO LIST A TAB1 RECORD ! COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN ! CHARACTER(LEN=24) HEAD,UNIT INTEGER OUTPUT REAL X(NP),Y(NP) ! ! SKIP IF FULL FILE NOT REQUESTED ! IF(OUTPUT.EQ.0) GO TO 300 ! ! OUTPUT HEADING ! NRR = MIN0(NP,5) WRITE(OUTPUT,10) (HEAD,JJ=1,NRR) 10 FORMAT(' Index ',5A24) IF(UNIT.NE.' ') WRITE(OUTPUT,20) (UNIT,JJ=1,NRR) 20 FORMAT(7X,5A24) ! ! OUTPUT DATA ! IF(NCONT.GT.0) GO TO 100 NA = 1 NB = NP NN = NP 100 NU = NB - NA + 1 DO 200 I=1,NU,5 II = MIN0(I+4,NU) NI = NA + I - 1 WRITE(OUTPUT,150) NI,(X(JJ),Y(JJ),JJ=I,II) 150 FORMAT(I5,2X,5(2(1PE11.4),2X)) 200 CONTINUE ! ! READ ANOTHER PAGE IF THERE ARE MORE ! IF(NB.EQ.NN) GO TO 300 CALL RDTAB(X,Y) GO TO 100 ! 300 RETURN END ! !*********************************************************************** ! SUBROUTINE LIBID(NLIB,NVER,LIBBCD) ! ! ROUTINE TO GENERATE LIBRARY ID FROM NLIB AND NVER ! CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=1) TCHAR CHARACTER(LEN=14) LIBTMP ! PARAMETER (NLIBS=13) CHARACTER(LEN=8) TLIBS(NLIBS) INTEGER LIBS(NLIBS) CHARACTER(LEN=5) NUMS(20) ! DATA TLIBS/'ENDF/B ','ENDF/A ','JEF ','EFF ', & & 'ENDF/HE ','CENDL ','JENDL ','INDL/V ', & & 'INDL/A ','INDL/F ','IRDF ','BROND ', & & 'UNKNOWN '/ DATA LIBS/0,1,2,3,4,5,6,31,32,33,34,41,99/ ! DATA NUMS /'I','II','III','IV','V','VI','VII','VIII', & & 'IX','X','XI','XII','XIII','XIV','XV','XVI','XVII', & & 'XVIII','XIX','?????'/ ! ! FIND LIBRARY ID ! DO 10 I=1,NLIBS-1 IF(NLIB.EQ.LIBS(I)) GO TO 15 10 CONTINUE I = NLIBS ! ! BUILD LIBRARY ID ! 15 IF(NLIB.GT.0.AND.NLIB.NE.4) GO TO 30 INVER = NVER IF(NVER.LT.1.OR.NVER.GT.19) INVER = 20 WRITE(LIBBCD,20) TLIBS(1)(1:6),NUMS(INVER) 20 FORMAT(A6,'-',A5) GO TO 100 30 WRITE(LIBTMP,40) TLIBS(I),NVER 40 FORMAT(A8,'-',I5) ! ! PACK ID LEFT JUSTIFIED ! LIBBCD = ' ' NCF = 0 DO 50 N=1,14 TCHAR = LIBTMP(N:N) IF(TCHAR.EQ.' ') GO TO 50 NCF = NCF + 1 LIBBCD(NCF:NCF) = TCHAR 50 CONTINUE ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE HEADIN(MAT,MF,MT,ZA) ! ! ROUTINE TO CREATE AND STORE EXPANDED TEXT FOR ZA, MF AND MT ! COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR ! ! SAVE MAT NUMBER IF GREATER THAN ZERO ! IF(MAT.GT.0) MATIN = MAT ! ! IF MF IS POSITIVE CHANGE FILE IDENTIFICATION ! IF(MF.GT.0) CALL MFID(NSUB,MF,MT,MFBCD,IERR) ! ! IF MT IS POSITIVE CHANGE REACTION IDENTIFICATION ! IF(MT.GT.0) CALL MTID(NFOR,NSUB,MT,MTBCD,IERR) ! ! IF IZ IS POSITIVE CHANGE ISOTOPE IDENTIFICATION ! IF(ZA.GT.0.0) CALL ZAID(ZA,ZABCD,IERR) ! RETURN END ! !*********************************************************************** ! SUBROUTINE ZAID(ZA,BCD,IERR) ! ! CONSTRUCTION OF THE ALPHANUMERIC REPRESENTATION OF AN ISOTOPE ! HAVING A GIVEN ATOMIC NUMBER AND WEIGHT. IF THE ATOMIC NUMBER IS ! LESS THAN OR EQUAL TO ZERO THE ISOTOPE IS ASSUMED TO BE A NATURAL ! ELEMENT ! ! SUBROUTINE ARGUMENTS ARE DEFINED AS FOLLOWS..... ! ZA = 1000.*Z + A ! BCD =RESULTING ALPHANUMERIC EQUIVALENT. ! IERR =ERROR INDICATOR. SET EQUAL TO ONE IF IZ IS NOT IN THE RANGE ! 1 TO 104, OR IA IS NOT IN THE RANGE 1 TO 999. IT IS ! SET EQUAL TO ZERO IF BOTH ARE IN ACCEPTABLE RANGE. ! ! THE NAME OF THE ELEMENT FOLLOWED BY ITS ATOMIC NUMBER IS LEFT ! ADJUSTED INTO ID. FOR NATURAL MATERIALS THE WORD 'NATURAL' ! FOLLOWED BY THE ELEMENT NAME IS USED INSTEAD. ! COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR ! CHARACTER(LEN=*) BCD CHARACTER(LEN=24) BCDX CHARACTER(LEN=1) CCHAR PARAMETER (ISPEC5=20) CHARACTER(LEN=20) SPMAT5(ISPEC5) INTEGER SANUM5(ISPEC5) PARAMETER (ISPEC6=18) CHARACTER(LEN=20) SPMAT6(ISPEC6) INTEGER SANUM6(ISPEC6) CHARACTER(LEN=3) NUMBER(7) CHARACTER(LEN=5) LETTER(3) CHARACTER(LEN=12) SPEED(2) PARAMETER (IELM=109) CHARACTER(LEN=13) ELEMNT(IELM) ! CHARACTER(LEN=24) GOOF DATA GOOF/'********(ERROR)*********'/ ! ! DEFINE SPECIAL MATERIAL LIBRARY FOR ENDF-5 FORMAT ! DATA SPMAT5/ 'Pure 1/V absorber ', & & 'Pure scatterer ','Water ', & & 'Heavy Water ','Biphenyl ', & & 'Sodium Hydroxide ','Santowax R ', & & 'Dowtherm A ','Benzene ', & & 'Beryllea ','Beryllium Carbide ', & & 'Beryllium Fluoride ','Zirconium Hydride ', & & 'Polystyrene ','Polyethylene ', & & 'Zircalloy 1 ','Zircalloy 2 ', & & '304 Stainless Steel ','Uranium Dioxide ', & & 'Uranium Carbide '/ DATA SANUM5/1,2,100,101,102,103,104,105,106,200, & & 201,202,203,204,205,301,302,304,310,315/ ! ! DEFINE SPECIAL MATERIAL LIBRARY FOR ENDF-6 FORMAT ! DATA SPMAT6/ 'Water ', & & 'Para Hydrogen ','Ortho Hydrogen ', & & 'Hydrogen in ZrH ','Heavy Water ', & & 'Para Deuterium ','Ortho Deuterium ', & & 'Beryllea ','Beryllium Oxide ', & & 'Beryllium Carbide ','Graphite ', & & 'Methane ','S-methane ', & & 'Polyethylene ','Benzene ', & & 'Zirconium in ZrH ','Uranium Dioxide ', & & 'Uranium Carbide '/ DATA SANUM6/1,2,3,7,11,12,13,26,27,28, & & 31,33,34,37,40,58,75,76/ ! ! DEFINE FISSION PRODUCT PARAMETERS ! DATA NUMBER/'23 ','25 ','49 ','41 ','02 ','28 ','40 '/ DATA LETTER/'RSFP ','SSFP ','NSFP '/ DATA SPEED/'SLOW REACTOR','FAST REACTOR'/ ! ! DEFINE ELEMENT NAMES ! DATA (ELEMNT(IJK),IJK=1,10)/ 'Hydrogen ', & & 'Helium ', & & 'Lithium ', & & 'Beryllium ', & & 'Boron ', & & 'Carbon ', & & 'Nitrogen ', & & 'Oxygen ', & & 'Fluorine ', & & 'Neon '/ DATA (ELEMNT(IJK),IJK=11,20)/ 'Sodium ', & & 'Magnesium ', & & 'Aluminum ', & & 'Silicon ', & & 'Phosphorus ', & & 'Sulfur ', & & 'Chlorine ', & & 'Argon ', & & 'Potassium ', & & 'Calcium '/ DATA (ELEMNT(IJK),IJK=21,30)/ 'Scandium ', & & 'Titanium ', & & 'Vanadium ', & & 'Chromium ', & & 'Manganese ', & & 'Iron ', & & 'Cobalt ', & & 'Nickel ', & & 'Copper ', & & 'Zinc '/ DATA (ELEMNT(IJK),IJK=31,40)/ 'Gallium ', & & 'Germanium ', & & 'Arsenic ', & & 'Selenium ', & & 'Bromine ', & & 'Krypton ', & & 'Rubidium ', & & 'Strontium ', & & 'Yttrium ', & & 'Zirconium '/ DATA (ELEMNT(IJK),IJK=41,50)/ 'Niobium ', & & 'Molybdenum ', & & 'Technetium ', & & 'Ruthenium ', & & 'Rhodium ', & & 'Palladium ', & & 'Silver ', & & 'Cadmium ', & & 'Indium ', & & 'Tin '/ DATA (ELEMNT(IJK),IJK=51,60)/ 'Antimony ', & & 'Tellurium ', & & 'Iodine ', & & 'Xenon ', & & 'Cesium ', & & 'Barium ', & & 'Lanthanum ', & & 'Cerium ', & & 'Praseodymium', & & 'Neodymium '/ DATA (ELEMNT(IJK),IJK=61,70)/ 'Promethium ', & & 'Samarium ', & & 'Europium ', & & 'Gadolinium ', & & 'Terbium ', & & 'Dysprosium ', & & 'Holmium ', & & 'Erbium ', & & 'Thulium ', & & 'Ytterbium '/ DATA (ELEMNT(IJK),IJK=71,80)/ 'Lutetium ', & & 'Hafnium ', & & 'Tantalum ', & & 'Tungsten ', & & 'Rhenium ', & & 'Osmium ', & & 'Iridium ', & & 'Platinum ', & & 'Gold ', & & 'Mercury '/ DATA (ELEMNT(IJK),IJK=81,90)/ 'Thallium ', & & 'Lead ', & & 'Bismuth ', & & 'Polonium ', & & 'Astatine ', & & 'Radon ', & & 'Francium ', & & 'Radium ', & & 'Actinium ', & & 'Thorium '/ DATA (ELEMNT(IJK),IJK=91,100)/ 'Protactinium', & & 'Uranium ', & & 'Neptunium ', & & 'Plutonium ', & & 'Americium ', & & 'Curium ', & & 'Berkelium ', & & 'Californium ', & & 'Einsteinium ', & & 'Fermium '/ DATA (ELEMNT(IJK),IJK=101,IELM)/'Mendelevium ', & & 'Nobelium ', & & 'Lawrencium ', & & 'Rutherfordium', & & 'Dubnium', & & 'Seborgium', & & 'Bohrium', & & 'Hassium', & & 'Meitnerium'/ ! ! INITIALIZE ! IERR=0 BCD = ' ' ! ! DETERMINE IZ AND IA ! IZ = ZA/1000. IA = ZA - 1000.*FLOAT(IZ) ! ! DETERMINE IF IZ AND IA ARE IN THE ALLOWABLE RANGE. ! IF(IZ.LT.0.OR.IZ.GT.IELM.OR.IA.GE.1000) GO TO 90 ! ! ZERO Z CORRESPONDS TO SPECIAL MATERIALS. ! IF(IZ.EQ.0) GO TO 50 ! ! ZERO A CORRESPONDS TO NATURAL ELEMENTS ! IF(IA.GT.0) GO TO 20 ! ! CONSTRUCT IDENTIFICATION FOR NATURAL MATERIAL ! BCD = 'Natural '//ELEMNT(IZ) GO TO 100 ! ! BUILD ISOTOPE NAME ! 20 WRITE(BCDX,25) IZ,ELEMNT(IZ),IA 25 FORMAT(I3,'-',A12,'-',I3) ! ! ELIMINATE IMBEDDED BLANKS ! NC = 0 DO 30 I=1,24 CCHAR = BCDX(I:I) IF(CCHAR.EQ.' ') GO TO 30 NC = NC + 1 BCD(NC:NC) = CCHAR 30 CONTINUE GO TO 100 ! ! CHECK AGAINST LIST OF SPECIAL ATOMIC WEIGHTS ! 50 IF(NFOR.GT.5) GO TO 75 IF(IA.GE.400.AND.IA.LE.499) GO TO 70 DO I=1,ISPEC5 IF(IA.LT.SANUM5(I)) THEN BCD = GOOF IERR=1 GO TO 100 ELSE IF(IA.EQ.SANUM5(I)) THEN BCD = SPMAT5(I) GO TO 100 END IF END DO GO TO 90 ! ! LUMPED FISSION PRODUCTS ! !*****COMPUTE MAJOR FISSION PRODUCT GROUP INDEX. 70 I1=MOD(IA,10)+1 IF(I1.GT.7) GO TO 90 !*****COMPUTE MINOR FISSION PRODUCT GROUP INDEX. I2=MOD(IA,100)/10 IF(I2.GT.5) GO TO 90 !*****DETERMINE CLASS OF REACTOR I3=I2/3+1 I2=MOD(I2,3)+1 !*****LOAD FISSION PRODUCT NUMBER, GROUP AND REACTOR CLASS BCD = NUMBER(I1)//LETTER(I2)//SPEED(I3) GO TO 100 ! ! ENDF-6 ! 75 IAM1 = IA - 100 IF(IAM1.LT.1.OR.IAM1.GT.99) GO TO 90 DO I=1,ISPEC6 IF(IAM1.LT.SANUM6(I)) THEN BCD = GOOF IERR=1 GO TO 100 ELSE IF(IAM1.EQ.SANUM6(I)) THEN BCD = SPMAT6(I) GO TO 100 END IF END DO GO TO 90 ! ! IZ AND/OR IA NOT VALID ! 90 BCD = GOOF IERR=1 ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE MFID(NSUB,MF,MT,BCD,IERR) ! ! DETERMINE THE ALPHANUMERIC EQUIVALENT FOR EACH FILE NUMBER. ! THE SUBROUTINE ARGUMENTS ARE DEFINED AS FOLLOWS.... ! MF =FILE NUMBER ! BCD =ALPHANUMERIC IDENTIFICATION FOR FILE MF. RETURNED AS ! CHARACTER*48 ! IERR =ERROR INDICATOR. IS SET TO ZERO IF MF IS AN ALLOWED. ! SET EQUAL TO ONE IF MF IS NOT ALLOWED. ! CHARACTER(LEN=48) BCD CHARACTER(LEN=48) GOOF PARAMETER (NMFS=24) CHARACTER(LEN=48) MMF(NMFS) INTEGER IMFS(NMFS) ! DATA GOOF/'********************(ERROR)*********************'/ ! ! DEFINE FILE IDENTIFICATION FOR NEUTRON INTERACTION DATA FILES ! DATA (MMF(IJK),IJK=1,7)/ & & ' Fission Parameters ', & & ' Resonance Parameters ', & & ' Reaction Cross Section ', & & ' Emitted Neutron Angular Distributions ', & & ' Emitted Neutron Energy Distributions ', & & ' Emitted Particle Energy-Angle Distributions ', & & ' Thermal Neutron Scattering Laws '/ DATA (IMFS(IJK),IJK=1,7)/1,2,3,4,5,6,7/ ! ! DEFINE FILE IDENTIFICATION FOR RADIOACTIVE DECAY FILES ! DATA (MMF(IJK),IJK=8,10)/ & & ' Radioactive Reaction Product Information ', & & ' Radioactive Nuclide Production Multiplicities ', & & ' Radioactive Nuclide Production Cross Sections '/ DATA (IMFS(IJK),IJK=8,10)/8,9,10/ ! ! DEFINE FILE IDENTIFICATION FOR PHOTON PRODUCTION FILES ! DATA (MMF(IJK),IJK=11,14)/ & & ' Photon Multiplicities (Neutron Induced) ', & & ' Photon Cross Sections (Neutron Induced) ', & & ' Photon Angular Distributions (Neutron Induced) ', & & ' Photon Energy Distributions (Neutron Induced) '/ DATA (IMFS(IJK),IJK=11,14)/12,13,14,15/ ! ! DEFINE FILE IDENTIFICATION FOR PHOTON INTERACTION FILES ! DATA (MMF(IJK),IJK=15,18)/ & & ' Photon Interaction Cross Section ', & & ' Emitted Particle Energy-Angle Distributions ', & & 'Incoherent and Coherent Photon Form Factor Data ', & & ' Atomic Relaxation Data '/ DATA (IMFS(IJK),IJK=15,18)/23,26,27,28/ ! ! DEFINE FILE IDENTIFICATION FOR COVARIANCE FILES ! DATA (MMF(IJK),IJK=19,NMFS)/ & & ' Nu Bar Covariance Data ', & & ' Resonance Parameter Covariance Data ', & & ' Reaction Cross Section Covariance Data ', & & ' Emitted Neutron Angular Covariance Data ', & & ' Emitted Neutron Energy Covariance Data ', & & ' Radioactive Nuclide Production Covariance Data '/ DATA (IMFS(IJK),IJK=19,NMFS)/31,32,33,34,35,40/ ! ! SEARCH FOR MATCHING FILE NUMBER (MF) ! DO I=1,NMFS IF(MF.LT.IMFS(I)) THEN BCD = GOOF IERR=1 GO TO 1000 ELSE IF(MF.EQ.IMFS(I)) THEN GO TO 100 END IF END DO BCD = GOOF IERR=1 GO TO 1000 ! ! FILE NUMBER IS NOT RECOGNIZED. SET IDENTIFICATION TO ERROR AND ! ERROR INDICATOR TO ONE. ! ! ! FILE NUMBER IS RECOGNIZED. SET IDENTIFICATION TO CORRESPONDING ! TEXT AND SET ERROR INDICATOR TO ZERO ! 100 IF(MF.EQ.8) THEN IF(MT.EQ.457) THEN BCD = ' Radioactive Decay Data' ELSE IF(MT.EQ.454.OR.MT.EQ.459) THEN BCD = ' Fission Product Yields' ELSE BCD = MMF(I) END IF ELSE IF(MF.EQ.23) THEN IF(NSUB.EQ.113) THEN BCD = ' Electron'//MMF(I)(15:) ELSE BCD = MMF(I) END IF ELSE BCD = MMF(I) END IF 250 IERR=0 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE MTID(NFOR,NSUB,MTIN,BCD,IERR) ! ! DETERMINE THE ALPHANUMERIC EQUIVALENT OF A REACTION TYPE NUMBER. ! THE SUBROUTINE ARGUMENTS ARE DEFINED AS FOLLOWS.... ! NSUB =SUBLIBRARY NUMBER (CONTAINS INCIDENT PARTICLE ID) ! MT =REACTION NUMBER ! BCD =ALPHANUMERIC EQUIVALENT OF A REACTION TYPE. RETURNED AS 5A4 ! IERR =ERROR INDICATOR. IF MT IS NOT IN THE LIBRARY IERR IS SET ! EQUAL TO ONE. IF MT O.K. IERR IS SET EQUAL TO ZERO ! CHARACTER(LEN=30) GOOF PARAMETER (NCRS=30) CHARACTER(LEN=*) BCD CHARACTER(LEN=1) CCHAR CHARACTER(LEN=30) BCDT CHARACTER(LEN=20) ILEV,JLEV PARAMETER (NPARTS=8) CHARACTER(LEN=6) PCODES(NPARTS+1) INTEGER ICLEN(NPARTS) INTEGER INMT(NPARTS) INTEGER IPZA(NPARTS) PARAMETER (NSHELS=39) CHARACTER(LEN=4) SHELL(NSHELS) CHARACTER(LEN=3) SUFO(4) PARAMETER (NMTS=93) CHARACTER(LEN=30) MMT(NMTS) INTEGER IMTS(NMTS) ! DATA GOOF/'***********(ERROR)************'/ ! ! DEFINE INCIDENT PARTICLE CODES ! DATA PCODES/'g','n','e','p','d','t','He-3','a',' '/ DATA ICLEN/6*1,4,1/ DATA INMT/102,4,0,103,104,105,106,107/ DATA IPZA/0,1,11,1001,1002,1003,2003,2004/ ! ! DEFINE SUBSHELLS ! DATA SHELL/'K ','L1 ','L2 ','L3 ','M1 ','M2 ','M3 ','M4 ','M5 ', & & 'N1 ','N2 ','N3 ','N4 ','N5 ','N6 ','N7 ','O1 ','O2 ', & & 'O3 ','O4 ','O5 ','O6 ','O7 ','O8 ','O9 ','P1 ','P2 ', & & 'P3 ','P4 ','P5 ','P6 ','P7 ','P8 ','P9 ','P10','P11', & & 'Q1 ','Q2 ','Q3 '/ ! ! DEFINE NUMERICAL SUFFIXES ! DATA SUFO/'-st','-nd','-rd','-th'/ ! ! DEFINE MT NUMBER CODES ! DATA (MMT(IJK),IJK=1,15)/ & & ',Total)', & & ',Elastic)', & & ',Non-Elastic)', & & ',n)', & & ',complex)', & & ',continuum emission)', & & ',2nd)', & & ',2n)', & & ',3n)', & & ',fission)', & & ',f)', & & ',nf)', & & ',2nf)', & & ',na)', & & ',n3a)'/ DATA (IMTS(IJK),IJK=1,15)/1,2,3,4,5,10,11,16,17,18,19,20,21,22,23/ DATA (MMT(IJK),IJK=16,32)/ & & ',2na)', & & ',3na)', & & ',absorption)', & & ',np)', & & ',n2a)', & & ',2n2a)', & & ',nd)', & & ',nt)', & & ',nHe-3)', & & ',nd2a)', & & ',nt2a)', & & ',4n)', & & ',3nf)', & & ',2np)', & & ',3np)', & & ',n2p)', & & ',npa)'/ DATA (IMTS(IJK),IJK=16,32)/24,25,27,28,29,30,32,33,34,35, & & 36,37,38,41,42,44,45/ DATA (MMT(IJK),IJK=33,48)/ & & ',disappearance)', & & ',g)', & & ',p)', & & ',d)', & & ',t)', & & ',He-3)', & & ',a)', & & ',2a)', & & ',3a)', & & ',2p)', & & ',pa)', & & ',t2a)', & & ',d2a)', & & ',pd)', & & ',pt)', & & ',da)'/ DATA (IMTS(IJK),IJK=33,48)/101,102,103,104,105,106,107,108,109, & & 111,112,113,114,115,116,117/ DATA (MMT(IJK),IJK=49,59)/ & & ',resonance data)', & & ',n production)', & & ',g production)', & & ',p production)', & & ',d production)', & & ',t production)', & & ',He-3 production)', & & ',He-4 production)', & & ',pi+ production)', & & ',pi0 production)', & & ',pi- production)'/ DATA (IMTS(IJK),IJK=49,59)/151,201,202,203,204,205,206,207,208, & & 209,210/ DATA (MMT(IJK),IJK=60,70)/ & & ',mu+ production)', & & ',mu- production)', & & ',K+ production)', & & ',K0(long) production)', & & ',K0(short) production)', & & ',K- production)', & & ',anti-p production)', & & ',anti-n production)', & & 'Mu Bar', & & 'Xi', & & 'Gamma'/ DATA (IMTS(IJK),IJK=60,70)/211,212,213,214,214,216,217,128,251, & & 252,253/ DATA (MMT(IJK),IJK=71,78)/ & & 'DOCUMENTATION', & & 'Fission Neutron Yields', & & 'Independent Yields', & & 'Delayed Fission Neutron Yields', & & 'Prompt Fission Neutron Yields', & & 'Decay Data', & & 'Energy Release per Fission', & & 'Cumulative Yields'/ DATA (IMTS(IJK),IJK=71,78)/451,452,454,455,456,457,458,459/ ! ! DEFINE PHOTON REACTIONS ! DATA (MMT(IJK),IJK=79,NMTS)/ & & 'Charged Part. Stopping Power', & & 'Photon Interaction Sigma', & & 'Photon Coherent Scattering ', & & 'Photon Incoherent Scattering', & & 'Imaginary Scattering Factor', & & 'Real Scattering Factor', & & 'Pair Prod.(Electron Field) ', & & 'Total Pair Production', & & 'Pair Prod.(Nuclear Field)', & & 'Photoelectric', & & 'Photo-Excitation', & & 'Electro-Atomic Elastic', & & 'Electro-Atomic Bremsstrahlung', & & 'Electro-Atomic Excitation', & & 'Atomic Relaxation'/ ! DATA (IMTS(IJK),IJK=79,NMTS)/500,501,502,504,505,506,515, & & 516,517,522,523,526,527,528,533/ ! ! INITIALIZE ! IERR = 0 BCD = ' ' MT = MTIN ! ! CONVERT IF INPUT FILE IS IN ENDF-V FORMAT ! IF(NFOR.GT.5) GO TO 30 IF(MT.GT.799) GO TO 30 IF(MT.GE.700) GO TO 10 IF(MT.EQ.602) MT = 522 GO TO 30 10 INDX = MT - 700 IPAR = INDX/20 INDX = INDX - 20*IPAR IF(INDX.EQ.19) INDX = 48 IF(INDX.EQ.18) INDX = 49 MT = 600 + 50*IPAR + INDX ! ! DETERMINE INCIDENT PARTICLE CODE ! 30 IPART = NSUB/10 DO I=1,NPARTS IF(IPART.LT.IPZA(I)) THEN GO TO 900 ELSE IF(IPART.EQ.IPZA(I)) THEN GO TO 45 END IF END DO CALL NUSYM(FLOAT(IPART),PCODES(NPARTS+1),JPLEN,IERR) IF(IERR.GT.0) GO TO 900 JPAR = NPARTS + 1 GO TO 48 45 JPAR = I JPLEN = ICLEN(JPAR) ! ! CHECK FOR NEUTRON EXCITED STATES ! 48 IF(MT.LT.50) GO TO 200 IF(MT.GT.91) GO TO 50 IPAR = 2 INDX = MT - 50 GO TO 60 ! ! CHECK FOR PROTON, TRITON, HELIUM-3 AND ALPHA EXCITED STATES ! 50 IF(MT.LT.600) GO TO 150 IF(MT.GT.849) GO TO 250 INDX = MT - 600 IPAR = INDX/50 + 3 INDX = INDX - 50*(IPAR-3) ! ! CREATE STRING TO DESCRIBE EXCITED FINAL STATE ! 60 IPLEN = ICLEN(IPAR) IF(INDX.GT.0) GO TO 75 !*****GROUND STATE ILEV = ') ground state' GO TO 100 !*****EXCITED STATE 75 IF(IPAR.EQ.2.AND.INDX.EQ.41) GO TO 90 IF(IPAR.GT.2.AND.INDX.EQ.49) GO TO 90 IF(NFOR.GT.5.OR.(IPAR.LE.2.OR.INDX.NE.48)) GO TO 78 ILEV = ') redundant' GO TO 100 78 ISUF = MIN0(INDX,4) WRITE(ILEV,80) INDX,SUFO(ISUF) 80 FORMAT(''')',I2,A3,' level') GO TO 95 !*****CONTINUUM 90 ILEV = ''') continuum' 95 IF(IPAR.NE.JPAR) THEN JLEV = ILEV(2:) ILEV = JLEV END IF 100 BCDT = '('//PCODES(JPAR)(1:JPLEN)//','//PCODES(IPAR)(1:IPLEN)// & & ILEV GO TO 800 ! ! ENERGY RELEASE RATE PARAMETERS ! 150 IF(MT.LT.301.OR.MT.GT.450) GO TO 180 MTER = MT - 300 WRITE(BCDT,175) MTER 175 FORMAT('E*SIGMA (MT=',I3,')') GO TO 800 ! ! PHOTO ELECTRIC SUBSHELLS ! 180 IF(MT.LT.534.OR.MT.GT.572) GO TO 200 ISHELL = MT - 533 IIND = INDEX(SHELL(ISHELL),' ') - 1 BCDT = SHELL(ISHELL)(1:IIND)//' Photoelectric Subshell' GO TO 800 ! ! SEARCH FOR MATCHING REACTION NUMBER ! 200 DO I=1,NMTS IF(MT.LT.IMTS(I)) THEN GO TO 900 ELSE IF(MT.EQ.IMTS(I)) THEN GO TO 220 END IF END DO GO TO 900 ! ! TRANSFER REPRESENTATION TO THE ARRAY BCDT ! 220 IF(MT.EQ.INMT(JPAR)) GO TO 230 CCHAR = MMT(I)(1:1) IF(CCHAR.EQ.',') GO TO 225 BCDT = MMT(I) GO TO 800 225 BCDT = '('//PCODES(JPAR)(1:JPLEN)//MMT(I) GO TO 800 !*****SPECIAL CASE OF INELASTIC 230 BCDT = '('//PCODES(JPAR)(1:JPLEN)//',Inelastic)' GO TO 800 ! ! LUMPED REACTION USED IN COVARIANCE FILES ! 250 IF(MT.GT.870) GO TO 900 BCDT = 'Lumped Reaction' GO TO 800 ! ! SECTION NUMBER IS RECOGNIZED. CENTER TEXT ! 800 DO 810 I=NCRS,1,-1 CCHAR = BCDT(I:I) IF(CCHAR.NE.' ') GO TO 820 810 CONTINUE GO TO 1000 820 INIT = (NCRS-I)/2 + 1 DO J=1,I BCD(INIT:INIT) = BCDT(J:J) INIT = INIT + 1 END DO GO TO 1000 ! ! SECTION NUMBER IS NOT RECOGNIZED, SET IDENTIFICATION TO ERROR ! AND ERROR FLAG TO ONE ! 900 BCD = GOOF IERR = 1 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE NUSYM(ZA,BCD,NCBCD,IERR) ! ! ROUTINE TO CONSTRUCT A NUCLIDE SYMBOL FROM ITS Z AND A ! CHARACTER(LEN=*) BCD CHARACTER(LEN=6) BCDX CHARACTER(LEN=1) CCHAR ! CHARACTER(LEN=6) GOOF PARAMETER(IELM=109) CHARACTER(LEN=2) ELEMNT(IELM) ! DATA GOOF/'******'/ ! ! DEFINE ELEMENT SYMBOLS ! DATA (ELEMNT(IJK),IJK=1,60)/ & & 'H ','He','Li','Be','B ','C ','N ','O ','F ','Ne', & & 'Na','Mg','Al','Si','P ','S ','Cl','Ar','K ','Ca', & & 'Sc','Ti','V ','Cr','Mn','Fe','Co','Ni','Cu','Zn', & & 'Ga','Ge','As','Se','Br','Kr','Rb','Sr','Y ','Zr', & & 'Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn', & & 'Sb','Te','I ','Xe','Cs','Ba','La','Ce','Pr','Nd'/ DATA (ELEMNT(IJK),IJK=61,IELM)/ & & 'Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb', & & 'Lu','Hf','Ta','W ','Re','Os','Ir','Pt','Au','Hg', & & 'Tl','Pb','Bi','Po','At','Rn','Fr','Ra','Ac','Th', & & 'Pa','U ','Np','Pu','Am','Cm','Bk','Cf','Es','Fm', & & 'Md','No','Lr','Rf','Db','Sg','Bh','Hs','Mt'/ ! ! INITIALIZE ! IERR=0 BCD = ' ' ! ! DETERMINE IZ AND IA ! IZ = ZA/1000. IA = ZA - 1000.*FLOAT(IZ) ! ! DETERMINE IF IZ AND IA ARE IN THE ALLOWABLE RANGE. ! IF(IZ.LT.0.OR.IZ.GT.IELM) GO TO 90 IF(IA.LT.0.OR.IA.GT.999) GO TO 90 ! ! NATURAL ELEMENT ! IF(IA.GT.0) GO TO 20 BCDX = 'nat-'//ELEMNT(IZ) GO TO 28 ! ! BUILD ISOTOPE NAME ! 20 WRITE(BCDX,25) IA,ELEMNT(IZ) 25 FORMAT(I3,'-',A2) ! ! ELIMINATE IMBEDDED BLANKS ! 28 NC = 0 DO 30 I=1,6 CCHAR = BCDX(I:I) IF(CCHAR.EQ.' ') GO TO 30 NC = NC + 1 BCD(NC:NC) = CCHAR 30 CONTINUE NCBCD = NC GO TO 100 ! ! IZ AND/OR IA NOT VALID ! 90 BCD = GOOF NCBCD = 6 IERR = 1 ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE TEXTR(ITAPE,TEXT,MAT,MF,MT) ! ! SUBROUTINE TO READ A TEXT RECORD ! COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN ! CHARACTER(LEN=66) TEXT ! NCONT = 0 READ(ITAPE,10) TEXT,MAT,MF,MT 10 FORMAT(A66,I4,I2,I3) RETURN ! END ! !*********************************************************************** ! SUBROUTINE CONT(ITAPE,C1,C2,L1,L2,N1,N2,MAT,MF,MT) ! ! READ A CONT RECORD ! COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN ! NCONT = 0 READ(ITAPE,10) C1,C2,L1,L2,N1,N2,MAT,MF,MT 10 FORMAT(2E11.4,4I11,I4,I2,I3) ! RETURN END ! !*********************************************************************** ! SUBROUTINE CANT(ITAPE,C1,C2,L1,L2,N1,N2,MAT,MF,MT,B) ! ! READ A LIST RECORD ! REAL B(*) ! ! READ CONT RECORD ! READ(ITAPE,10)C1,C2,L1,L2,N1,N2,MAT,MF,MT 10 FORMAT(2E11.4,4I11,I4,I2,I3) ! ! READ IN ARRAY ! READ(ITAPE,20) (B(I),I=1,N1) 20 FORMAT(6E11.4) ! RETURN END ! !*********************************************************************** ! SUBROUTINE CANT1(ITAPE,C1,C2,L1,L2,N1,N2,MAT,MF,MT,NBT,INT,X,Y) ! ! READ A TAB1 RECORD ! COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN ! INTEGER NBT(20),INT(20) REAL X(*),Y(*) ! ! READ CONT RECORD ! NCONT = 0 READ(ITAPE,10)C1,C2,L1,L2,N1,N2,MAT,MF,MT 10 FORMAT(2E11.4,4I11,I4,I2,I3) ! ! READ INTERPOLATION TABLE ! READ(ITAPE,20) (NBT(I),INT(I),I=1,N1) 20 FORMAT(6I11) ! ! READ IN ARRAY ! IF(N2.GT.MAXY)GO TO 50 READ(ITAPE,30) (X(I),Y(I),I=1,N2) 30 FORMAT(6E11.4) GO TO 100 ! ! POINT LIMIT IS EXCEDED SO CREATE PAGING FILE ! 50 CALL OPSCR(1) NCONT = 3*(MAXY/3) ! ! FILL PAGING FILE ! 70 NU = MIN0(NCONT,N2-NN) READ(ITAPE,30) (X(I),Y(I),I=1,NU) WRITE(NSCR) (X(I),Y(I),I=1,NU) NN = NN + NU IF(NN.LT.N2) GO TO 70 ! ! LOAD FIRST PAGE INTO CORE ! CALL OPSCR(2) CALL RDTAB(X,Y) ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE CANT2(ITAPE,C1,C2,L1,L2,N1,N2,MAT,MF,MT,NBT,INT) ! ! READ A TAB2 RECORD ! COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN ! INTEGER NBT(20),INT(20) ! ! READ CONT RECORD ! NCONT = 0 READ(ITAPE,10) C1,C2,L1,L2,N1,N2,MAT,MF,MT 10 FORMAT(2E11.4,4I11,I4,I2,I3) ! ! READ INTERPOLATION TABLE ! READ(ITAPE,20) (NBT(I),INT(I),I=1,N1) 20 FORMAT(6I11) ! RETURN END ! !*********************************************************************** ! SUBROUTINE OPSCR(INEW) ! ! ROUTINE TO INITIALIZE A PAGING FILE ! COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN ! LOGICAL SCROPN ! ! BRANCH ON OPTION ! IF(INEW.EQ.2) GO TO 50 ! ! DELETE ANY EXISTING FILE ! NCONT = 0 INQUIRE(UNIT=NSCR,OPENED=SCROPN) IF(SCROPN) CLOSE(UNIT=NSCR,STATUS='DELETE') ! ! OPEN NEW PAGE FILE ! OPEN(UNIT=NSCR,STATUS='NEW',ACCESS='SEQUENTIAL', & & FORM='UNFORMATTED') NN = 0 GO TO 100 ! ! PREPARE PAGE FILE FOR READING ! 50 ENDFILE (UNIT=NSCR) REWIND (UNIT=NSCR) NA = 0 NB = 0 ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE RDTAB(X,Y) ! ! ROUTINE TO READ A PAGE OF A TAB1 RECORD FROM SCRATCH ! COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN ! REAL X(5000),Y(5000) ! 10 NA = NB + 1 NB = MIN0(NB+NCONT,NN) NU = NB - NA + 1 IF(NU.GT.0) GO TO 20 REWIND (UNIT=NSCR) NB = 0 GO TO 10 20 READ(NSCR) (X(I),Y(I),I=1,NU) ! RETURN END ! !*********************************************************************** ! SUBROUTINE SKPMAT(ITAPE) ! ! SKIP REMAINDER OF A DATA SET (MATERIAL) ! 10 READ(ITAPE,20) MAT 20 FORMAT(66X,I4) IF(MAT.GT.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE SKPFIL(ITAPE) ! ! SKIP THE REMAINDER OF A FILE ! 10 READ(ITAPE,20) MF 20 FORMAT(70X,I2) IF(MF.NE.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE SKPSEC(ITAPE) ! ! SKIP THE REMAINDER OF A SECTION ! 10 READ(ITAPE,20) MT 20 FORMAT(72X,I3) IF(MT.NE.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE SKPREC(ITAPE,I) ! ! SKIP I RECORDS ! DO 20 J=1,I READ(ITAPE,10) MT 10 FORMAT(72X,I3) 20 CONTINUE ! RETURN END ! !*********************************************************************** ! SUBROUTINE LEGEND(P,N,M,X0,X1) ! ! GENERATE A TABLE OF LEGENDRE POLYNOMIAL FROM P1 TO PN AT M ! EQUALLY SPACED POINTS SUCH THAT THE FIRST IS X0 AND THE LAST IS ! X1. THE ORDER N MUST BE AT LEAST 3 AND THE NUMBER OF POINTS ! MUST BE AT LEAST 2. NO CHECK IS MADE TO SEE IF THESE CRITERIA ARE ! MET. THEREFORE FAILURE TO SATISFY THEM MAY RESULT IN ERRORS. ! REAL P(M,N) ! ! COMPUTE SPACING ! DX=(X0-X1)/FLOAT(M-1) ! ! INITIALIZE POSITION ! X=X0 ! ! BEGIN LOOP OVER POINTS ! DO 100 I=1,M ! ! COMPUTE P1 AND P2 ! P(I,1)=X P(I,2)=1.5*X*X-0.5 AJ=2. ! ! BEGIN LOOP OVER ORDERS ! DO J=3,N AJ=AJ+1. ! ! USE RECURSION RELATIONSHIP TO GENERATE HIGHER ORDER TERMS ! P(I,J)=((2.*AJ-1.)*X*P(I,J-1)-(AJ-1.)*P(I,J-2))/AJ END DO ! ! INCREMENT POSITION ! X=X-DX 100 CONTINUE ! RETURN END ! !*********************************************************************** ! SUBROUTINE ANGLAR(DSDO,FL,P,NL,N,M) ! ! RECONSTRUCT ANGULAR DISTRIBUTION FROM LEGENDRE COEFFICIENTS ! REAL DSDO(M),FL(NL),P(M,N) ! ! INITIALIZE DISTRIBUTION TO P0 CONTRIBUTION AND (2*J+1)/2 TO 0.5 ! DO J=1,M DSDO(J)=0.5 END DO IF(NL.LT.1) RETURN AJ=0.5 DO K=1,NL AJ=AJ+1. AJFLK=AJ*FL(K) DO J=1,M DSDO(J)=DSDO(J)+AJFLK*P(J,K) END DO END DO ! RETURN END ! !*********************************************************************** ! SUBROUTINE DATE_20(DATE) ! ! RETURNS DATE AS A CHARACTER STRING OF 11 CHARACTERS IN THE ! FORM DD-MMM-YYYY ! CHARACTER(LEN=*) DATE CHARACTER(LEN=26) CDATE CHARACTER(LEN=8) PDATE CHARACTER(LEN=4) YR CHARACTER(LEN=2) DD INTEGER MON ! CHARACTER(LEN=3) MONTHS(12) DATA MONTHS/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',& & 'Oct','Nov','Dec'/ ! ! GET THE DATE AND TIME AS A CHARACTER STRING ! !+++MDC+++ !...VMS, WIN CALL DATE_AND_TIME(PDATE) READ(PDATE,'(A4,I2,A2)') YR,MON,DD DATE = DD//'-'//MONTHS(MON)//'-'//YR !...UNX !/ CALL FDATE(CDATE) !/ DATE = CDATE(10:12)//CDATE(6:9)//CDATE(22:25) !...ANS !/ DATE = ' ' !---MDC--- RETURN END