PROGRAM CHMF35 C-Title : CHMF35 Program C-Purpose: Test ENDF spectrum covariance matrices C-Author : A. Trkov, Jozef Stefan Institute, Ljubljana, Slovenia C-Version: February 2009 beta C-M C-M Manual for Program CHMF35 C-M ========================= C-M C-M Description C-M ----------- C-M A source ENDF file is processed to check specific file C-M deficiencies as follows. C-M C-M NLIB code for JENDL-3 library: C-M The ENDF-6 code for the JENDL libraries is NLIB=6. The C-M JENDL-3.3 library is released without the NLIB value set. C-M CHMF35 corrects for this deficiency. C-M C-M Missing neutron-emission discrete level photon files (MF12): C-M JENDL evaluators omitted discrete level photon data for C-M metastable states. Physically this is a feasible representation C-M since the photons are emitted with a delay and the ENDF-6 C-M manual is not very specific on this issue. Practically, it C-M causes processing problems with NJOY. An interim solution is C-M to insert the missing level data, define full transition to C-M the ground state (TP=1), but set the conditional transition C-M to zero (GP=0). CHMF35 inserts the missing levels as C-M described above. C-M C-M Zero-sum rule of the spectrum covariance matrices (MF35): C-M The report file contains the summary of deviations from the rule C-M and includes the following for each covariance energy bin: C-M i bin index C-M R_i deviation from the zero-sum in ppm (=Sum_j F_ij/P_i) C-M Elo covariance grid lower energy boundary C-M P_i spectrum probability in the energy bin C-M Sum_j F_ij row sum of matrix elements C-M Esp energy of the tabulated spectrum point C-M Sp(Esp) Spectrum value at Esp. C-M C-M The matrix is renormalised according to the recipe from the C-M ENDF manual. C-M C-M Instructions C-M ------------ C-M In response to the prompt on the terminal enter the following C-M filenames C-M - The source ENDF file to be processed. C-M - The ENDF file to contain the corrected data. C-M C-M The report is written on "chmf35.lst". C- PARAMETER (MGL=1000,MXRW=40000,MXCOM=6) CHARACTER*66 C66,H66,COM(MXCOM) CHARACTER*40 BLNK,FLNM,FLIN,FLOU,FLEN,FLSC DOUBLE PRECISION DEI,DEJ,DPJ,PPI,DPI,PPJ,SSF,SMX DOUBLE PRECISION COV DIMENSION COV(MGL,MGL) DIMENSION RWO(MXRW),QQ50(50) DIMENSION NBT(20),INR(20),ENP(2),XSP(2) C* Filenames and logical file units DATA LIN,LOU,LEN,LSC,LKB,LTT / 1, 2, 3, 4, 5, 6 / DATA BLNK/' '/ 1 ,FLIN/'chmf35.dat'/ 2 ,FLOU/'chmf35.lst'/ 3 ,FLEN/'chmf35.end'/ 4 ,FLSC/'chmf35.tmp'/ C* Initialise JEN33=0 ONE= 1 ZRO= 0 IZR= 0 ION= 1 MON=-1 C* C* Write banner to terminal WRITE(LTT,991) ' CHMF35 - Fission Spectrum Covariances ' WRITE(LTT,991) ' ===================================== ' WRITE(LTT,991) C* Define the source file 12 WRITE(LTT,991) ' Default source filename : ',FLIN WRITE(LTT,991) '$ Enter new name to redefine : ' READ (LKB,991) FLNM IF(FLNM.NE.BLNK) FLIN=FLNM OPEN(UNIT=LIN,FILE=FLIN,STATUS='OLD',ERR=12) C* Define the output ENDF file 14 WRITE(LTT,991) ' Default output ENDF filename : ',FLEN WRITE(LTT,991) '$ Enter new name to redefine : ' READ (LKB,991) FLNM IF(FLNM.NE.BLNK) FLEN=FLNM OPEN (UNIT=LEN,FILE=FLEN,STATUS='UNKNOWN') C* Define the output list file 16 WRITE(LTT,991) ' Default output list filename : ',FLOU C... WRITE(LTT,991) '$ Enter new name to redefine : ' C... READ (LKB,991) FLNM C... IF(FLNM.NE.BLNK) FLOU=FLNM OPEN (UNIT=LOU,FILE=FLOU,STATUS='UNKNOWN') WRITE(LOU,991) ' CHMF35 - Fission Spectrum Covariances ' WRITE(LOU,991) ' ===================================== ' WRITE(LOU,991) WRITE(LOU,991) ' Source ENDF filename : ',FLIN WRITE(LOU,991) ' Output corrected ENDF filename : ',FLEN WRITE(LOU,991) C* Prepare the scratch file OPEN (UNIT=LSC,FILE=FLSC,STATUS='UNKNOWN') C* C-F Copy the library header NS=-1 CALL RDTEXT(LIN,MAT,MF,MT,C66,IER) IF(IER.NE.0) STOP 'CHMF35 ERROR - Reading source ENDF file' 90 CALL WRTEXT(LEN,MAT,MF,MT,NS,C66) C* C-F Start reading the data for the next material 100 IMF5=0 NMF5=0 REWIND LSC C66='CHMF35 Scratch file '//BLNK LLL=7777 NSS=0 CALL WRTEXT(LSC,LLL,IZR,IZR,NSS,C66) C-F Identify the source library CALL RDHEAD(LIN,MAT,MF,MT,ZA ,AWR, LRP, LFI, NLIB,NMOD,IER) IF(IER.NE.0) STOP 'CHMF35 ERROR - Reading source ENDF file' IF(MAT.LT.0) GO TO 780 CALL RDHEAD(LIN,MAT,MF,MT,ELIS,STA, LIS, LIS0,IDM, NFOR,IER) IF(IER.NE.0) STOP 'CHMF35 ERROR - Reading source ENDF file' CALL RDHEAD(LIN,MAT,MF,MT,AWI ,EMAX,LREL,IDM, NSUB,NVER,IER) IF(IER.NE.0) STOP 'CHMF35 ERROR - Reading source ENDF file' CALL RDHEAD(LIN,MAT,MF,MT,TEMP,DMY, LDRV,IDM, NWD, NXC, IER) IF(IER.NE.0) STOP 'CHMF35 ERROR - Reading source ENDF file' DO I=1,MXCOM CALL RDTEXT(LIN,MAT,MF,MT,COM(I),IER) IF(IER.NE.0) STOP 'CHMF35 ERROR - Reading source ENDF file' END DO WRITE(LTT,*) COM(1) WRITE(LTT,*) COM(3) WRITE(LTT,*) ' ' C* -- Check if JENDL-3.3 C* Note: JENDL-3.3 has no NLIB - identified from comments only C66=COM(3) IF(NLIB.NE.0) JEN33=0 IF(C66(1:12).EQ.'----JENDL-3.') THEN NLIB =6 IF(JEN33.NE.1) THEN JEN33=1 WRITE(LOU,*) 'JENDL-3 Library identified' WRITE(LOU,*) ' ' END IF END IF NWD=NWD+2 C-F Write the material header information CALL WRCONT(LEN,MAT,MF,MT,NS,ZA ,AWR, LRP, LFI, NLIB,NMOD) CALL WRCONT(LEN,MAT,MF,MT,NS,ELIS,STA, LIS, LIS0,IDM, NFOR) CALL WRCONT(LEN,MAT,MF,MT,NS,AWI ,EMAX,LREL,IDM, NSUB,NVER) CALL WRCONT(LEN,MAT,MF,MT,NS,TEMP,DMY, LDRV,IDM, NWD, NXC ) C-F Copy the comment section and add the CHMF35 mark C* -- Copy first two lines unconditionally CALL WRTEXT(LEN,MAT,MF,MT,NS,COM(1)) CALL WRTEXT(LEN,MAT,MF,MT,NS,COM(2)) IWD=NWD-2 C* -- Copy standard text and blank records DO I=3,MXCOM C66=COM(I) CALL WRTEXT(LEN,MAT,MF,MT,NS,C66) IWD=IWD-1 IF(C66(1:4).NE.'----' .AND. C66(1:4).NE.' ') EXIT END DO C* -- Insert CHMF35 mark C66='CHMF35 - Checking of MF35 covariance matrices'//BLNK CALL WRTEXT(LEN,MAT,MF,MT,NS,C66) C66=BLNK//BLNK CALL WRTEXT(LEN,MAT,MF,MT,NS,C66) IWD=IWD-2 C* -- Copy the rest of the comments DO I=1,IWD CALL RDTEXT(LIN,MAT,MF,MT,C66,IER) IF(IER.NE.0) STOP 'CHMF35 ERROR - Reading source ENDF file' CALL WRTEXT(LEN,MAT,MF,MT,NS,C66) IF(C66(1:12).EQ.'CHMF35 - Checking of') JEN33=0 END DO C* C-F Copy up to MF35 but save MF5 sections to scratch CALL RDTEXT(LIN,MAT,MF,MT,C66,IER) IF(IER.NE.0) STOP 'CHMF35 ERROR - Reading source ENDF file' MT50=50 C* Find energy spectra covariances DO WHILE (MF.NE.35 .OR. MT.NE.18) CALL WRTEXT(LEN,MAT,MF,MT,NS,C66) CALL RDTEXT(LIN,MAT,MF,MT,C66,IER) IF(IER.NE.0) STOP 'CHMF35 ERROR - Reading source ENDF file' IF(MAT.EQ.0) GO TO 90 IF(MAT.LT.0) THEN C* -- Last material read - no MF35 data GO TO 780 END IF C* C* -- Save Q-value if discrete inelastic data found IF(MF.EQ.3 .AND. (MT.GE.51.AND.MT.LT.91)) THEN CALL WRTEXT(LEN,MAT,MF,MT,NS,C66) CALL RDTEXT(LIN,MAT,MF,MT,C66,IER) READ (C66,901) DMY,QQ QQ50(MT-50)=QQ GO TO 120 END IF C* C* -- Save spectrum data to scratch file IF(MF.EQ.5 .OR. MF.EQ.6) IMF5=1 IF(MF.GT.6) THEN H66=BLNK//BLNK LLL=-1 IMF=0 CALL WRTEXT(LSC,LLL,IZR,IZR,NSS,H66) END IF IF(IMF5.EQ.1) THEN NMF5=NMF5+1 CALL WRTEXT(LSC,MAT,MF,MT,NSS,C66) END IF C* C* -- Insert missing levels for discrete level neutron emission IF(MF.EQ.12 .AND. (MT.GE.51.AND.MT.LT.91)) THEN 110 MT50=MT50+1 IF(MT50.LT.MT) THEN WRITE(LOU,*) ' Missing level MAT,MF,MT',MAT,MF,MT50 WRITE(LOU,*) ' Assume transition to ground state' WRITE(LOU,*) ' ' NS=0 I02=2 I03=3 IMT=MT50-50 CALL WRCONT(LEN,MAT,MF,MT50,NS, ZA,AWR,I02,I02,I03,IZR) QQI=QQ50(IMT) RWO(1)=QQI RWO(2)=ONE DO J=3,6 RWO(J)=ZRO END DO CALL WRLIST(LEN,MAT,MF,MT50,NS,QQI,ZRO,IZR,IZR,I03,ION,RWO) C66=BLNK//BLNK CALL WRTEXT(LEN,MAT,MF,IZR,NS,C66) GO TO 110 END IF GO TO 120 END IF CYCLE C* -- Copy to the end of section 120 DO WHILE(MT.GT.0) CALL WRTEXT(LEN,MAT,MF,MT,NS,C66) CALL RDTEXT(LIN,MAT,MF,MT,C66,IER) END DO END DO C* C* -- MF35 data found - write the head record CALL WRTEXT(LEN,MAT,MF,MT,NS,C66) IF(NMF5.LE.0) THEN WRITE(LOU,*) 'CHMF35 WARNING - MF35 found but no MF5 data' GO TO 720 END IF READ (C66,901) ZA,AWR,IDM,IDM,NK,IDM DO IK=1,NK C* -- Read the MF35 covariance matrix CALL RDLIST(LIN,ELO,EHI,LS,LB,NT,NE,RWO,MXRW,IER) IF(IER.NE.0) STOP 'CHMF35 ERROR - Reading source ENDF file' IF(LB.NE.7) THEN WRITE(LOU,*) 'CHMF35 WARNING - MF35 found but LB not 7' LEB=1 GO TO 710 END IF NE1=NE-1 C* Adresses: C* LEB - Energy boundaries C* LSU - Row-sums C* LEP - Spectrum bin probabilities C* LBL - First free word LEB=1 LSU=LEB+NE LEP=LSU+NE1 LBL=LEP+NE1 c... c... go to 710 c... C* -- Expand the covariance matrix into COV, ro-sums at LSU C* Note: original matrix in RWO is overwritten NRW=MXRW-LEB CALL UPMF35(LIN,JEN33,COV,MGL,NE,RWO(LSU),RWO(LEB),NRW) c... c... go to 700 c... c... print *,'Spectrum',ik,elo,ehi ,rwo(leb+ne1) c... do i=1,ne c... if(i.le.3) print *,i,(cov(j,i),j=1,3) c... end do c... C* -- Find the spectra in MF5 REWIND LSC MFX=0 MTX=0 MTS=MT DO WHILE (MFX.NE.5 .OR. MTX.NE.MTS) CALL RDTEXT(LSC,MATX,MFX,MTX,H66,IER) IF(IER.NE.0 .OR. MATX.LT.0) THEN STOP 'CHMF35 ERROR - No MF5 data on file' END IF END DO READ (H66,901) C1,C2,IDM,IDM,NKS,IDM IF(NKS.GT.1) THEN WRITE(LOU,*) ' CHMF35 WARNING - Multiple sections in spectra' WRITE(LOU,*) ' Normalisation skipped' GO TO 700 END IF C* -- Reserve array for the spectrum (overwrite matrix) NMX=(MXRW-LBL)/2 K1 =LBL K2 =K1+NMX LBL=K2+NMX IF(LBL.GT.MXRW) STOP 'CHMF35 ERROR - MXRW limit exceeded' C... C... PRINT *,'K1,K2,NMX',K1,K2,NMX C... C* -- Read the multiplicity CALL RDTAB1(LSC,C1,C2,L1,LF,NR,NP,NBT,INR & ,RWO(K1),RWO(K2),NMX,IER) IF(IER.NE.0) THEN WRITE(LOU,*) ' CHMF35 WARNING - Problem reading spectra' WRITE(LOU,*) ' Normalisation skipped' GO TO 700 END IF IF(LF.EQ.1) THEN C* -- Read the spectrum panel interpolation law CALL RDTAB2(LSC,C1,C2,L1,L2,NRS,NES,NBT,INR,IER) IF(IER.NE.0) STOP 'CHMF35 ERROR in RDTAB2 for spectra' C* -- Read the spectra until Ein is within interval DO IS=1,NES CALL RDTAB1(LSC,C1,EIN,L1,L2,NR,NP,NBT,INR & ,RWO(K1),RWO(K2),NMX,IER) IF(IER.NE.0) STOP 'CHMF35 ERROR in RDTAB1 for spectra' IF(EIN.LT.ELO .AND. IS.LT.NES) CYCLE C* -- Compare row-sums to the spectrum value C... C... print *,'Take spectrum at',EIN,elo C... IN =2 EB=RWO(LEB) DO I=1,NE1 EA=EB EB=RWO(LEB +I) CALL YTGEOU(PP,EA,EB,NP,RWO(K1),RWO(K2),IN) RWO(LEP-1+I)=PP C... C... print *,'i,dp,sdf',i,rwo(lsu-1+i),ssf,pp C... END DO EXIT END DO ELSE WRITE(LOU,*) ' CHMF35 WARNING - Unsupported LF in spectra' WRITE(LOU,*) ' Normalisation skipped' GO TO 700 END IF C-F Correct the covariance matrix normalisation SSF=0 SMX=0 DO I=1,NE1 DPI=DBLE(RWO(LSU-1+I)) PPI=DBLE(RWO(LEP-1+I)) SSF=SSF+DPI IF(PPI.GT.0) THEN SMX=MAX(ABS(DPI/PPI),SMX) ELSE SMX=9.99E29 END IF END DO C* -- Print the sum of the rows to the log file IF(SMX.GT.1.0D-6) THEN WRITE(LOU,*) ' ' WRITE(LOU,*) ' Spectrum of MAT,MF,MT',MAT,MF,MT & ,' E-range(eV)',ELO,EHI WRITE(LOU,*) ' i R_i(ppm) Elo P_i Sum_j' & ,' F_ij Esp Sp(Esp)' END IF DO I=1,NE1 DPI=DBLE(RWO(LSU-1+I)) PPI=DBLE(RWO(LEP-1+I)) C... C... if(i.eq.1) print *,'dpi,ppi,ssf',dpi,ppi,ssf C... DO J=1,NE1 DPJ=DBLE(RWO(LSU-1+J)) PPJ=DBLE(RWO(LEP-1+J)) COV(J,I)=COV(J,I)-(DPJ*PPI + DPI*PPJ - PPI*PPJ*SSF) END DO C* EA=RWO(LEB-1+I) IDD=1D6*(DPI/PPI) IF(SMX.GT.1.0D-6) & WRITE(LOU,'(i4,i8,1p,e10.2,4e14.6)') I,IDD,EA,PPI,DPI & ,RWO(K1-1+I),RWO(K2-1+I) END DO C-F Pack the corrected matrix into the work arraj 700 LL=LEB+NE1 C* -- Enegies already in the array, add the covariance matrix DO I=1,NE1 c... dei=rwo(leb+i)-rwo(leb-1+i) c... c... if(i.le.3) print *,i,(cov(j,i),j=1,3) c... DO J=I,NE1 LL=LL+1 c... dej=rwo(leb+j)-rwo(leb-1+j) c... RWO(LL)=COV(J,I)/(dei*dej) RWO(LL)=COV(J,I) END DO END DO C-F Write the corrected covariance matrix 710 CALL WRLIST(LEN,MAT,MF,MT,NS,ELO,EHI,LS,LB,NT,NE,RWO(LEB)) END DO C* Copy the rest of the file 720 DO WHILE (MAT.GT.0) CALL RDTEXT(LIN,MAT,MF,MT,C66,IER) CALL WRTEXT(LEN,MAT,MF,MT,NS,C66) END DO GO TO 100 780 C66=BLNK//BLNK MAT=-1 CALL WRTEXT(LEN,MAT,MF,MT,NS,C66) C* End of file processing 800 STOP 'CHMF35 Completed' C* 901 FORMAT(2F11.0,4I11) 991 FORMAT(2A40) END SUBROUTINE UPMF35(LIN,JEN33,COV,MGL,NE,SUM,RWO,MXRW) C-Title : Subroutine UPMF35 C-Purpose: Unpack MF 35 covariance matrix C-Description: C-D JEN33 Flag to indicate if the covariance matrix is given on C-D bin probabilities of probability distributions C-D COV Full covariance matrix (double precision) (output) C-D MGL Maximum order of the covariance matrix C-D NE Number of energy points C-D SUM Row-sums of matrix elements for each row (output) C-D RWO Packed covariance matrix in LB=7 ENDF format option C-D MXRW Maximum size of the work array C- DOUBLE PRECISION COV,SS,CC,E1,E2,E3,E4,DI,DJ DIMENSION COV(MGL,MGL) DIMENSION SUM(MGL),RWO(MXRW) C* NE1=NE-1 LE =1 LC =LE+NE LL =LC E2 =DBLE(RWO(LE)) DO I=1,NE1 E1=E2 E2=DBLE(RWO(LE+I)) DI=E2-E1 E4=E1 DO J=I,NE1 E3=E4 E4=DBLE(RWO(LE+J)) DJ=E4-E3 CC=DBLE(RWO(LL)) C* -- If JEN33 flag set, convert covariances of C* density distributions to bin probabilities IF(JEN33.EQ.1) CC=CC*DJ*DI COV(J,I)=CC COV(I,J)=CC LL=LL+1 END DO END DO DO I=1,NE1 SS=0 DO J=1,NE1 SS=SS+COV(I,J) END DO SUM(I)=SS C... C... Print *,'Row',I,'Sum',ss,di,e1 C... END DO RETURN END SUBROUTINE RDTEXT(LEF,MAT,MF,MT,REC,IER) C-Title : RDTEXT Subroutine C-Purpose: Read a text record to an ENDF file CHARACTER*66 REC READ (LEF,40,END=81,ERR=82) REC,MAT,MF,MT IER=0 RETURN 81 IER=1 RETURN 82 IER=2 RETURN 40 FORMAT(A66,I4,I2,I3,I5) END SUBROUTINE RDHEAD(LEF,MAT,MF,MT,C1,C2,L1,L2,N1,N2,IER) C-Title : Subroutine RDHEAD C-Purpose: Read an ENDF HEAD record C-Description: C-D The HEAD record of an ENDF file is read. The following error C-D conditions are trapped by setting the IER flag: C-D IER = 0 Normal termination C-D 1 End-of-file C-D 2 Read error C- READ (LEF,92) C1,C2,L1,L2,N1,N2,MAT,MF,MT RETURN 92 FORMAT(2F11.0,4I11.0,I4,I2,I3,I5) END SUBROUTINE RDTAB1(LEF,C1,C2,L1,L2,N1,N2,NBT,INR,EN,XS,NMX,IER) C-Title : Subroutine RDTAB1 C-Purpose: Read an ENDF TAB1 record C-Description: C-D The TAB1 record of an ENDF-formatted file is read. C-D Error condition: C-D IER=1 End-of-file C-D 2 Read error C-D -8 WARNING - Numerical underflow (E+36) C-D 9 WARNING - Available field length exceeded, NMX entries read. C- DOUBLE PRECISION EE(3),XX(3) DIMENSION NBT(1),INR(1) DIMENSION EN(NMX), XS(NMX) C* IER=0 READ (LEF,902,END=100,ERR=200) C1,C2,L1,L2,N1,N2 READ (LEF,903,END=100,ERR=200) (NBT(J),INR(J),J=1,N1) JP=N2 IF(N2.GT.NMX) THEN JP=NMX IER=9 END IF JR=(JP+2)/3 J=0 DO K=1,JR READ(LEF,904,END=100,ERR=200) (EE(M),XX(M),M=1,3) DO M=1,3 J=J+1 IF(J.LE.JP) THEN IF(ABS(XX(M)).LT.1E-36) THEN XX(M)=0 C... IER=-8 ELSE IF(ABS(XX(M)).GT.1.E36) THEN XX(M)=1E36 IER=8 END IF EN(J)=EE(M) XS(J)=XX(M) END IF END DO END DO RETURN 100 IER=1 RETURN 200 IER=2 RETURN C* 902 FORMAT(2F11.0,4I11) 903 FORMAT(6I11) 904 FORMAT(6F11.0) END SUBROUTINE RDTAB2(LEF,C1,C2,L1,L2,N1,N2,NBT,INR,IER) C-Title : Subroutine RDTAB2 C-Purpose: Read an ENDF TAB2 record C-D Error condition: C-D IER=1 End-of-file C-D 2 Read error DIMENSION NBT(1),INR(1) C* READ (LEF,902,END=100,ERR=200) C1,C2,L1,L2,N1,N2 READ (LEF,903,END=100,ERR=200) (NBT(J),INR(J),J=1,N1) RETURN 100 IER=1 RETURN 200 IER=2 RETURN C* 902 FORMAT(2F11.0,4I11) 903 FORMAT(6I11) END SUBROUTINE RDLIST(LEF,C1,C2,L1,L2,N1,N2,VK,MVK,IER) C-Title : Subroutine RDLIST C-Purpose: Read an ENDF LIST record DOUBLE PRECISION RUFL,RR(6) DIMENSION VK(1) C* READ (LEF,902) C1,C2,L1,L2,N1,N2 IF(N1+5.GT.MVK) THEN IER=-1 RETURN END IF IF(N1.EQ.0) RETURN C* Read the LIST2 entries, watch for underflow NUFL=0 RUFL=1 DO J=1,N1,6 READ (LEF,903) (RR(K),K=1,6) DO K=1,6 IF(RR(K).NE.0 .AND. ABS(RR(K)).LT.1.E-30) THEN NUFL=NUFL+1 IF(ABS(RR(K)).LT.ABS(RUFL)) RUFL=RR(K) END IF VK(J-1+K)=RR(K) END DO END DO IF(NUFL.GT.0) THEN PRINT *,' RDLIST WARNING - Underflow conditions',NUFL PRINT *,' Minimum number',RUFL END IF RETURN C* 902 FORMAT(2F11.0,4I11) 903 FORMAT(6F11.0) END SUBROUTINE WRCONT(LIB,MAT,MF,MT,NS,C1,C2,L1,L2,N1,N2) C-Title : WRCONT Subroutine C-Purpose: Write a CONT record to an ENDF file CHARACTER*11 BLN,REC(6) DATA BLN/' '/ DO 10 I=1,6 REC(I)=BLN 10 CONTINUE IF( (C1.EQ.0. .AND. C2.EQ.0.) .AND. 1 (L1.EQ.0 .AND. L2.EQ.0 ) .AND. 2 (N1.EQ.0 .AND. N2.EQ.0 ) ) GO TO 12 CALL CHENDF(C1,REC(1)) CALL CHENDF(C2,REC(2)) WRITE(REC(3),20) L1 WRITE(REC(4),20) L2 WRITE(REC(5),20) N1 WRITE(REC(6),20) N2 12 NS=NS+1 IF(NS.GT.99999) NS=0 IF(MT.EQ.0) NS=99999 IF(MF.EQ.0) NS=0 WRITE(LIB,40) (REC(J),J=1,6),MAT,MF,MT,NS RETURN 20 FORMAT(I11) 40 FORMAT(6A11,I4,I2,I3,I5) END SUBROUTINE WRTAB1(LIB,MAT,MF,MT,NS,C1,C2,L1,L2 1 ,NR,NP,NBT,INR,X,Y) C-Title : WRTAB1 Subroutine C-Purpose: Write a TAB1 record to an ENDF file CHARACTER*11 BLN,REC(6) DIMENSION NBT(NR),INR(NR),X(NP),Y(NP) DATA BLN/' '/ C* First line of the TAB1 record CALL CHENDF(C1,REC(1)) CALL CHENDF(C2,REC(2)) WRITE(REC(3),42) L1 WRITE(REC(4),42) L2 WRITE(REC(5),42) NR WRITE(REC(6),42) NP NS=NS+1 IF(NS.GT.99999) NS=0 WRITE(LIB,40) (REC(J),J=1,6),MAT,MF,MT,NS C* Write interpolation data N =0 20 I =0 22 REC(I+1)=BLN REC(I+2)=BLN IF(N.GE.NR) GO TO 24 N =N+1 WRITE(REC(I+1),42) NBT(N) WRITE(REC(I+2),42) INR(N) 24 I =I +2 IF(I.LT.6) GO TO 22 NS=NS+1 IF(NS.GT.99999) NS=0 WRITE(LIB,40) (REC(J),J=1,6),MAT,MF,MT,NS IF(N.LT.NR) GO TO 20 C* Loop for all argument&function pairs N =0 30 I =0 32 REC(I+1)=BLN REC(I+2)=BLN IF(N.GE.NP) GO TO 34 N =N+1 CALL CHENDF(X(N),REC(I+1)) CALL CHENDF(Y(N),REC(I+2)) 34 I =I+2 IF(I.LT.6) GO TO 32 NS=NS+1 IF(NS.GT.99999) NS=0 WRITE(LIB,40) (REC(J),J=1,6),MAT,MF,MT,NS IF(N.LT.NP) GO TO 30 RETURN 40 FORMAT(6A11,I4,I2,I3,I5) 42 FORMAT(I11) END SUBROUTINE WRTAB2(LIB,MAT,MF,MT,NS,C1,C2,L1,L2 1 ,NR,NZ,NBT,INT) C-Title : WRTAB2 Subroutine C-Purpose: Write a TAB2 record to an ENDF file CHARACTER*11 BLN,REC(6) DIMENSION NBT(1),INT(1) DATA BLN/' '/ C* First line of the TAB2 record CALL CHENDF(C1,REC(1)) CALL CHENDF(C2,REC(2)) WRITE(REC(3),42) L1 WRITE(REC(4),42) L2 WRITE(REC(5),42) NR WRITE(REC(6),42) NZ NS=NS+1 WRITE(LIB,40) (REC(J),J=1,6),MAT,MF,MT,NS IF(NZ.LE.0) RETURN C* Write interpolation data N =0 20 I =0 22 REC(I+1)=BLN REC(I+2)=BLN IF(N.GE.NR) GO TO 24 N =N+1 WRITE(REC(I+1),42) NBT(N) WRITE(REC(I+2),42) INT(N) 24 I =I +2 IF(I.LT.6) GO TO 22 NS=NS+1 WRITE(LIB,40) (REC(J),J=1,6),MAT,MF,MT,NS IF(N.LT.NR) GO TO 20 RETURN 40 FORMAT(6A11,I4,I2,I3,I5) 42 FORMAT(I11) END SUBROUTINE WRLIST(LIB,MAT,MF,MT,NS,C1,C2,L1,L2,NPL,N2,BN) C-Title : WRLIST Subroutine C-Purpose: Write a LIST record to an ENDF file CHARACTER*11 BLN,REC(6) DIMENSION BN(1) DATA BLN/' '/ C* First line of the TAB2 record CALL CHENDF(C1,REC(1)) CALL CHENDF(C2,REC(2)) WRITE(REC(3),42) L1 WRITE(REC(4),42) L2 WRITE(REC(5),42) NPL WRITE(REC(6),42) N2 NS=NS+1 WRITE(LIB,40) (REC(J),J=1,6),MAT,MF,MT,NS IF(NPL.EQ.0) RETURN C* Write data N =0 20 I =0 22 REC(I+1)=BLN IF(N.GE.NPL) GO TO 24 N =N+1 CALL CHENDF(BN(N),REC(I+1)) 24 I =I +1 IF(I.LT.6) GO TO 22 NS=NS+1 WRITE(LIB,40) (REC(J),J=1,6),MAT,MF,MT,NS IF(N.LT.NPL) GO TO 20 RETURN 40 FORMAT(6A11,I4,I2,I3,I5) 42 FORMAT(I11) END SUBROUTINE WRTEXT(LIB,MAT,MF,MT,NS,REC) C-Title : WRTEXT Subroutine C-Purpose: Write a text record to an ENDF file CHARACTER*66 REC NS=NS+1 IF(MT.EQ.0) NS=99999 IF(MF.EQ.0) NS=0 IF(NS.GT.99999) NS=0 WRITE(LIB,40) REC,MAT,MF,MT,NS IF(MT.EQ.0) NS=0 RETURN 40 FORMAT(A66,I4,I2,I3,I5) END SUBROUTINE CHENDF(FF,CH) C-Title : CHENDF Subroutine C-Purpose: Pack value into 11-character string CHARACTER*1 SN CHARACTER*11 CH CH=' 0.00000+00' FA=ABS(FF) IA=0 C* Trap unreasonably large values, print as "9.99999+99" if(fa.gt.1e30) then CH=' 9.99999+99' return end if C* Check for small values, print as zero 20 IF(FA.LT.1.0E-30 ) RETURN C* Condition mantissa of small numnbers IF(FA.LT.9.999950) GO TO 40 FA=FA/10 IA=IA+1 GO TO 20 C* Condition mantissa of large numnbers 40 IF(FA.GE.0.999995) GO TO 50 FA=FA*10 IA=IA-1 GO TO 40 C* Sign of the exponent 50 SN='+' IF(IA.LT.0) THEN SN='-' IA=-IA END IF C* Sign of the mantissa IF(FF.LT.0) FA=-FA C* Write character fiels WRITE(CH,80) FA,SN,IA RETURN 80 FORMAT(F8.5,A1,I2.2) END SUBROUTINE YTGEOU(PMU,EA,EB,NEP,EOU,DXS,INR) C-Title : Subroutine YTGEOU C-Purpose: Integrate a pointwise tabulated function over EA - EB C-Author : A.Trkov, IAEA, Vienna, Austria C-Version: C-V 05/01 Fix interpolation at energy boundaries C* WARNING: Only lin-lin or histogram interpolation allowed DIMENSION EOU(NEP),DXS(NEP) C* PMU=0 E2=EOU(1) F2=DXS(1) DO 20 I=2,NEP E1=E2 F1=F2 E2=EOU(I) F2=DXS(I) C* Treat lower energy bound IF(E2.LT.EA) GO TO 20 IF(E1.LT.EA) THEN IF(INR.EQ.2) F1=F1+(F2-F1)*(EA-E1)/(E2-E1) E1=EA END IF IF(E1.GE.EB) RETURN C* Treat upper energy bound IF(E2.GT.EB) THEN IF(INR.LT.2) THEN F2=F1 ELSE F2=F1+(F2-F1)*(EB-E1)/(E2-E1) END IF E2=EB END IF C* Define average function value over the interval FF=0.5*(F2+F1) C* Add interval contribution to the integral PMU=PMU+FF*(E2-E1) 20 CONTINUE C* RETURN END