*/
*/ OECD/NEA compilation of NJOY updates
*/ compatible with the official patch distribution up336
*/
*/ The patches include those carried-over from the previous
*/ official updates but not adopted in up336.
*/
*ident upnea001
*/ njoy - C. Broeders, 6-Oct-2006
*/        Open scratch files in local disc area
*/        Ref.: Comments by D.E. Cullen in PrePro-2004 (Scratcha.f) on p.19 of:
*/        "http://www-nds.iaea.org/ndspub/endf/prepro/DOCUMENT/PDF/Overview.pdf"
*/        Status "scratch" does not work with Lahey compiler on Linux,
*/        therefore 'age" is set "unknown"
*d njoy.470
         age='unknown'
*d njoy.471
         write(fn,'(a,i2.2)') 'temp',nun
         open(nun,file=fn,form=for,status=age)  
*/
*ident upnea004
*/ groupr - C. Broeders, 6-Oct-2006
*/          extend IWT=5 spectrum definition up to 200MeV
*/ -------------------------------------------
*d groupr.2145
      dimension w1(92),w2(92),w3(10)
*d groupr.2150
      data w1/0d0,0d0,0d0,0d0,1.d0,93.d0,93.d0,5.d0,
*i groupr.2175
      data w3/3.d7,1.0318d-10,5.d7,6.1908d-11,1.d8,3.0954d-11,
     &1.5d8,2.0636d-11,2.d8,1.5477d-11/
*d groupr.2358
      iw=194
*i groupr.2365
      do i=1,10
         a(i+183+iwght)=w3(i)
      enddo
*/
*/ *ident upnea019 is included in up265
*/
*/ *ident upnea020 is included in up235
*/
*/ *ident upnea021 is included in up261
*/
*/ *ident upnea022 is included in up260
*/
*/ *ident upnea023 is included in up272
*/
*/ *ident upnea024 is included in up273
*/
*/ *ident upnea025 is included in up315
*/
*/ *ident upnea026 is included in up316
*/
*/ *ident upnea027 is included mostly in up317, except a few statements
*/                 which are placed in upnea068
*/
*/ *ident upnea028 is included in up318
*/
*/ *ident upnea029 is included in up316
*/
*/ *ident upnea030 is included in up272
*/
*/ *ident upnea031 is included in up289
*/
*ident upnea032
*/ acer     A. Trkov, 30 May 2008
*/          Plots of discrete inelastic make sense below 10 MeV
*d acer.19586
c                       limit discrete inelastic plots to 10 MeV
                        if (x.gt.xmax) xmax=min(x,10.)
*/
*/ *ident upnea033 included in up278
*/
*/ *ident upnea034 included in up277
*/
*/ *ident upnea035 included in up279
*/
*/ *ident upnea036 included in up279
*/
*/ *ident upnea037 included in up277
*/
*ident upnea038
*/ covr    A. Trkov, 20 October 2008
*          Fix diagnostic message
*d covr.1793,1805
      zero=0
      if (abs(crit).gt.zero) write(strng,                                                      covr.1794 
     &      '(''i'',i3,'' j'',i3,'' xa(i,j)='',1p,e12.4,'' xa(j,i)='',
     &     1p,e12.4)') i,im1,xa(im1ind,i),xa(iind,im1)
      if (abs(crit).gt.test .and. abs(xa(im1ind,i)).gt.1e-20) then                                          covr.1793 
         call error('press','matrix not symmetric',strng)
      endif
      test=1
      test=test/1000000
      if (abs(crit).lt.test) go to 250
      call mess('press','matrix not symmetric',strng)
*/
*/ *ident upnea039 included in up272
*/
*ident upnea040
*/
*/ GROUPR - R. Perry, 15 October 2008
*/          (Original update name: upwe6)
*/          Problem with thermal scattering matricies in GROUPR            
*/          There were small discrepancies between the sums thermal scatter
*/          matrices and the group cross-sections. This update renormalises
*/          the interpolated spectra (produced during integration)
*/          to sum to unity.
*/          (guarding against array overflow added by A. Trkov)
*i groupr.6915
      integer nsi
      parameter (mxnsi=15000)
*i groupr.6922
      dimension sint(2,mxnsi)
*i groupr.7030
      nsi = 0
*i groupr.7146
c
c store interpolated function. 
c
      nsi = nsi+1
      if(nsi.gt.mxnsi)
     &   call error('getaed','mxnsi array limit exceeded',' ')
      sint(1,nsi) = ei
      sint(2,nsi) = fi(1)
*i groupr.7155
c
c sum interpolated spectrum and adjust aed. 
c
      sisum = 0.0
      do il = 1, nsi - 1
        sisum = sisum + (sint(2,il)+sint(2,il+1))*
     &                                  (sint(1,il+1)-sint(1,il))/2
      enddo
c
c don't re-normalise if scatter source above top energy group. 
c
      if(i .lt. ngn .or. (k1 .eq. nlo .and. k2 .eq. nhi) ) then 
        do il = 1, i
          aed(1,il) = aed(1,il)/sisum
        enddo
      endif
*/
*/ *ident upnea041 included in up282
*/
*/ *ident upnea042 is not included; it is redefined in upnea069
*/
*/ *ident upnea043 included in up282
*/
*/ *ident upnea044 included in up273
*/
*/ *ident upnea045 included in up282
*/
*/ *ident upnea046 withdrawn
*/
*/ *ident upnea047 included in up287
*/
*/ *ident upnea048 included in up329 and extended
*/
*/ *ident upnea049 is included in up290
*/
*/ *ident upnea050 is included in up289
*/
*ident upnea051
*/ errorr Tsuneo Nakagawa, Go Chiba, July 2009
*/        (original idents provided by the authors: nkgw, cbg)
*/        More robust treatment to identify resonance parameters
*/        with given uncertainties (the list can be reduced from
*/        the end, but no skipping is allowed).
*i errorj.6734
      data mpid /1,3,4,5,6,0/
*d up279.38,50
*i up279.56
      mm=0   
*d up279.61,67
*d up287.9
         do m=1,5
           mm=mm+1
           ii=l3+mpid(m)-1
           cov(mm,mm)=a(ii)
         enddo
*d up279.74,76
      l3=lbg+6 
      l2=lbg+6 
      do n2=1,nrb
*i up279.100
c
      mpar=nnn/nrb
      if(mpar.ne.5)then
        mm=0
        do nr=1,nrb
          mbase=5*(nr-1)
          do m=1,mpar
            mm=mm+1
            mmm=mbase+m
            cov(mm,mm)=cov(mmm,mmm)
          enddo
        enddo
      endif
c
      if(nm.ne.0)then
      nw=ndigit
*i up279.122
      endif
*/ 
*/ Modification for high-speed calculation option of errorr
*/
*d up290.49
            e2=1.0+(eskip1-1.0)*5.
*/
*ident upnea052
*/ covr  R. Perel, July 2009
*/       Patches up273 and up283 have been erroneously applied
*/       inside an update "*if sw" statement. Restore the
*/       integrity of the *if statements for long-word machines.
*i covr.947
*else
      xsize=5.00e0
      ysize=3.38e0
*endif
*d covr.948,951
*i covr.1418
*endif
*d covr.1419
*/
*/ the following correction has been performed as part of up273
*/ but it was applied there to sw-mode only
*/ here: apply it if not sw-mode
*d up192.7
      data tlev/0.001e0,0.1e0,0.2e0,0.3e0,0.6e0,1.0e0/
*/
*/ *ident upnea053 is included in up307
*/
*ident upnea054
*/ errorr D.L. Aldama, July 2009
*/        Fix weighting function option
*d errorj.660
      if (iwt.eq.1.or.iwt.eq.4.or.iwt.eq.5.or.
     &     (iwt.ge.7.and.iwt.lt.11))
*d errorj.1492
      if (iwt.eq.1.or.iwt.eq.4.or.iwt.eq.5.or.
     &     (iwt.ge.7.and.iwt.lt.11))
*/
*/ *ident upnea055 is included in up314
*/
*/ *ident upnea056 is included in up312
*/
*/ *ident upnea057 is included in up305
*/
*/ *ident upnea058 is included in up318
*/
*/ *ident upnea059 is included in up205
*/
*/ *ident upnea060 is not needed due to alternative coding in up329
*/
*/ *ident upnea061 is superseeded by upnea068
*/
*/ *ident upnea062 is included in up324
*/
*/ *ident upnea063 is dealt with differently in upnea315
*/
*ident upnea064
*/ acer    A. Trkov, February 2010
*/         Particle emission spectra in the acer plots are corrupted
*/         for MF6 Law 1 LANG 1 when more than one interpolation range
*/         is specified for the distributions on incident particle
*/         energies. In some cases the MCNP calculations are also wrong.
*/         A fix is done when writing the data to a temporary file.
*/         The multiple ranges are suppressed. The first interpolation
*/         law is prescribed over the entire incident energy range
*/         and a message is printed.
*/         WARNING:
*/         This is a temporary patch before a proper solution is found.
*/         The true error probably occurs somewhere near acer.6651
*/         or later, and/or possibly in MCNP.
*/         Implications:
*/         JENDL-HE files truncated to 150 MeV (as proposed for FENDL-3)
*/         led to strongly discrepant results in a benchmark model
*/         calculation representative of the ITER device. The discrepancy
*/         is greatly reduced with the use of this patch. The assumption
*/         in the patch has no influence on the evaluated data because
*/         the interpolation law changes above 20 MeV where the yield
*/         drops to zero due to the reaction representation in MT5.
*d acer.2373,2374
                  call tab2io(nin,0,0,b,nb,nw)
                  nr=n1h
                  ne=nint(b(6))
                  if(nr.gt.1) then
                    write(string,'(a,i3)')
     &                   'multiple interp. ranges for mf6, mt',mt
                    call mess('topfil',string
     &                    ,'first law applied everywhere')
                    nr=1
                    b(5)=nr
                    b(7)=ne
                  end if
                  call tab2io(0,nout,0,b,nb,nw)
*/
*ident upnea065
*/ mixr    A. Trkov, March 2010
*/         - Increase array size
*/         - fix loop index
*d mixr.54
      dimension a(300000)
*i mixr.74
      mxlna=300000
*i mixr.314
            je=je+1
*i mixr.318
            if(inow.gt.mxlna) then
               call error('mixr','mxlna array limit exceeded',' ')
            end if
*/
*ident upnea066
*/ errorr  A. Trkov, March 2010
*/         Increase maxb array size (request from Emmeric Dupont)
*d errorj.6339
      parameter (maxe=400000,mxnpar=4000,maxb=40000)
*/
*ident upnea067
*/ errorr  A. Trkov, April 2010
*/       - Correct error trap
*/       - Relocate covariance data counting loop introduced in upnea062
*/         (previous position could be bypassed in some cases and caused
*/         execution termination)
*d errorj.479,480
      if (nga.gt.nwi)
     &  call error('errorr','too many reaction types for mf 34.',' ')
*i errorj.484
      if (nlump.gt.nlmt)
     &  call error('errorr','too many lumped reaction types',' ')
*/ Relocate covariance data counting loop
*i errorj.467
      icov=0
*i errorj.472
c
c     ***check dictionary for required files
         if (mfcov.eq.30.and.(mf.ge.30 .and. mf.le.33)) icov=icov+1
         if (mfcov.eq.31.and.mf.eq.31) icov=icov+1
         if (mfcov.eq.32.and.mf.eq.32) icov=icov+1
         if (mfcov.eq.33.and.(mf.eq.32.or.mf.eq.33)) icov=icov+1
         if (mfcov.eq.34.and.mf.eq.34) icov=icov+1
         if (mfcov.eq.35.and.mf.eq.35) icov=icov+1
         if (mfcov.eq.40.and.mf.eq.40) icov=icov+1
*d up324.84,96
c     *** check if there are data on file to process
*/
*ident upnea068
*/ acer    A. Trkov, January 2010
*/         (Revision of upnea061, noticed by Skip Kahler)
*d acer.119,120
c     *               7   read fast ace files to print or edit         *
c     *               8   read thermal ace files to print or edit      *
c     *               9   read dosimetry ace files to print or edit    *
*d acer.407
      else if (iopt.eq.6.or.iopt.gt.9) then
*d acer.435  
      else if (iopt.ge.7.and.iopt.le.9) then
*i acer.17639
c
c     ***read type 3 ace format file
      else if (itype.eq.3) then
         if (mcnpx.eq.0) then
           read(nin) hz(1:10),aw0,tz,hd,hko,hm,(izo(i),awo(i),i=1,16),
     &       (nxs(i),i=1,16),(jxs(i),i=1,32)
         else
           read(nin) hz(1:13),aw0,tz,hd,hko,hm,(izo(i),awo(i),i=1,16),
     &       (nxs(i),i=1,16),(jxs(i),i=1,32)
         endif
         len2=nxs(1)
         n=(len2+ner-1)/ner
         l=0
         do i=1,n
            max=len2-l
            if (max.gt.ner) max=ner
            read (nin) (xss(l+j),j=1,max)
            l=l+max
         enddo
         call closz(-nin)
c        flag incident particle "undefined"
         izai=-1
         awi =-1
*/
*ident upnea069
*/ groupr  A. Trkov, 6-Feb-2009
*/         Truncation of the minimum cross section causes problems
*/         in the case of the fission spectrum when processing
*/         covariance matrices. Update upnea029 is refined to
*/         decrease the tolerance by a factor 1000, and abolish
*/         it if processing mt=18 spectrum
*d up316.13
      if (a(ised-1+ik+nk*(ig-1)).gt.smin/1000.or.mtd.eq.18) go to 280
*/
*ident upnea070
*/ errorr  A. Trkov, April 2010
*/         - Important update for processing MF35:
*/           When trying to prevent overflow, the criterion on the
*/           denominator affected some real cases and corrupted the
*/           covariance matrix of the fission spectra
*/         - clean-up coding
*d up324.265
*/ clean up coding
*d up329.17,19
c     *            zero.  This variable is only defined for mfcov=32   *
c     *            or 33 and if non-zero will be used in lieu of any   *
c     *            data that might have been read from the nendf tape. *
*d up329.27
         if ((mfcov.eq.32.or.mfcov.eq.33).and.dap.ne.0) isru=1
*d up324.202
*d errorj.987
            if (mt1.lt.851) then
               call rdsig(mat1,mt1,izero,a(ib),a(isig1))
            else
               call lumpxs(mt1,mtl,a)
            end if
*/