*$ CREATE USRSUW.FOR
*COPY USRSUW
*
*=== Usrsuw ===========================================================*
*
      PROGRAM USRSUW
*
*----------------------------------------------------------------------*
*                                                                      *
*     Copyright (C) 1994-2008      by    Alfredo Ferrari & Paola Sala  *
*     All Rights Reserved.                                             *
*                                                                      *
*                                                                      *
*     USer Residual scoring SUm and Weighting and EVolution:           *
*                                                                      *
*     Created on  14 october 1994  by    Alfredo Ferrari & Paola Sala  *
*                                                   Infn - Milan       *
*                                                                      *
*     Last change on 03-jun-08     by    Alfredo Ferrari               *
*                                                                      *
*                                                                      *
*----------------------------------------------------------------------*
*
      CHARACTER FILE*80,FILE1*80,RUNTIT*80,RUNTIM*32,CHSTAT*10,CHERR*3,
     &          CHISMR*10, CHCTOT*15
*$ CREATE USRSNC.ADD
*COPY USRSNC
*
*=== usrsnc ==========================================================*
*
*---------------------------------------------------------------------*
*     Module usrsnc:                                                  *
*     A. Ferrari : user defined residual nuclei scoring               *
*                  estimators                                         *
*          Last change A. Ferrari 22-jul-1994                         *
*                                                                     *
*                                                                     *
*     Up to MXRSNC user defined track or coll are allowed             *
*            lursnc = logical flag, .true. if at least 1 user defined *
*                     residual nuclei scoring is activated            *
*            nursnc = number of residual nuclei scoring               *
*            izrhgh = maximum Z of the scoring (minimum Z: 1)         *
*            imrhgh = maximum M=N-Z-NMZ_min of the scoring            *
*                    (minimum M: 1), please note:                     *
*                     N-Z = M + NMZ_min, N = M + Z + NMZ_min          *
*            itursn = type of binning: 1 = spallation products,       *
*                     2 = low energy neutrons products,               *
*                     3 = all products                                *
*            nrursn = region                                          *
*            vursnc = volume (cm**3) of the detector                  *
*            tiursn = scoring name                                    *
*            ipursn = logical unit to print the results on: formatted *
*                     if > 0, unformatted if < 0                      *
*            kbursn = initial location in blank common of the consi-  *
*                     dered residual nuclei scoring (real*8 address)  *
*                     I T   I S   F O R  A D D R E S S  OF  0 !!!!!   *
*                                                                     *
*---------------------------------------------------------------------*
*
      PARAMETER ( MXRSNC = 400 )
*     PARAMETER ( NMZMIN =  -5 )
      LOGICAL LURSNC
      CHARACTER*10 TIURSN
      COMMON /USRSCN/  VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC),
     &                 NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC),
     &                 IPURSN(MXRSNC), KDCYUR(MXRSNC), NISMRS(MXRSNC),
     &                 NURSNC, LURSNC
      COMMON /USRSCH/  TIURSN(MXRSNC)
      PARAMETER ( MXDUMM = 500000 )
      PARAMETER ( MXIRRD = 300 )
      PARAMETER ( NMXGRP = 300 )
      PARAMETER ( NMXEBN = 500 )
      PARAMETER ( MXARSN = 400 )
      DIMENSION GMSTOR (MXDUMM), GDSTOR (MXDUMM), GBSTOR (MXDUMM),
     &          TOTTOT (MXRSNC), TOTERR (MXRSNC),
     &          KAURSN (MXRSNC), JX (MXRSNC),
     &          ACCUMA (NMXEBN+NMXGRP), ACCUMZ (NMXEBN+NMXGRP),
     &          RCCUMA (NMXEBN+NMXGRP),
     &          RCCUMZ (NMXEBN+NMXGRP), TDECAY (MXRSNC),
     &          BIRHLP (MXIRRD), TIRHLP (MXIRRD),
     &          BIRRDT (MXIRRD), TIRRDT (MXIRRD),
     &          KZURSN (MXRSNC), IABEG (100), IAEND (100)
      PARAMETER ( AZRZRZ = 1.0D-30 )
      PARAMETER ( ZERZER = 0.0D+00 )
      DOUBLE PRECISION GDSTOR, ACCUMP, GBSTOR, ACCUMA, ACCUMZ, AFACT,
     &                 TOTTOT, TOTERR, DSCORE, WCTOT , ADUMMY, BDUMMY,
     &                 BIRRDT, TIRRDT
      REAL      GMSTOR, BIRHLP, TIRHLP, RCCUMA, RCCUMZ, TDECAY
      LOGICAL   LSTATI, LCHECK, LISMRS, LFIEND, LEVOLN, LOFFEV, LOLDIR
      DIMENSION IASTLN (100), RESNUC (100,MXARSN), RESERR (100,MXARSN)
      DATA IASTLN / 
     &     1,       4,       7,       9,      11,      12,
     &    14,      16,      19,      20,      23,      24,
     &    27,      28,      31,      32,      35,      40,
     &    39,      40,      45,      48,      51,      52,
     &    55,      56,      59,      59,      64,      65,
     &    70,      73,      75,      79,      80,      84,
     &    86,      88,      89,      91,      93,      96,
     &    97,     101,     103,     107,     108,     113,
     &   115,     118,     122,     128,     127,     131,
     &   133,     137,     139,     140,     141,     144,
     &   145,     150,     152,     157,     159,     163,
     &   165,     167,     169,     173,     175,     179,
     &   181,     184,     186,     190,     192,     195,
     &   197,     201,     204,     207,     209,     209,
     &   210,     222,     223,     226,     227,     232,
     &   231,     238,     237,     244,     243,     247,
     &   247,     251,     254,     257 /
*
*     Note that all addresses are for zero index (KBURSN,KAURSN)
*
      DO 5555 I = 1, MXDUMM
         GBSTOR (I) = ZERZER
         GDSTOR (I) = ZERZER
 5555 CONTINUE
      DO 4444 I = 1, MXRSNC
         TOTTOT (I) = ZERZER
         TOTERR (I) = ZERZER
         NISMRS (I) = 0
 4444 CONTINUE
      CHERR  = '+/-'
      NCTOT  = 0
      MCTOT  = 0
      WCTOT  = ZERZER
      MBATCH = 0
      LSTATI = .FALSE.
      LISMRS = .FALSE.
      LEVOLN = .FALSE.
      CALL ISOINI
      KLAST  = 0
      KMAX   = 0
      NRNDC  = 0
      K0     = 0
      LQOLD  = 0
 1111 CONTINUE
      LFIEND = .FALSE.
      WRITE(*,'('' Type the input file: '',$)')
      READ (*,'(A)')FILE
      LQ     = LNNBLN (FILE)
      IF (LQ .LE. 0) GO TO 2000
      OPEN (UNIT=1,FILE=FILE,STATUS='OLD',FORM='UNFORMATTED',ERR=1111)
      IRECRD = 0
      READ (1,ERR=100) RUNTIT, RUNTIM, WEIPRI, NCASE, MCASE, NBATCH
      IRECRD = IRECRD + 1
      WRITE(*,*) RUNTIT
      WRITE(*,*) RUNTIM
      WRITE(*,*) WEIPRI
      WRITE(*,*) ABS (NCASE)
      WRITE(*,*) ABS (MCASE)
      WRITE(*,*) NBATCH
      GO TO 200
 100  CONTINUE
      REWIND 1
      IRECRD = 0
      READ (1,ERR=110) RUNTIT, RUNTIM, WEIPRI, NCASE, NBATCH
      IRECRD = IRECRD + 1
      WRITE(*,*) RUNTIT
      WRITE(*,*) RUNTIM
      WRITE(*,*) WEIPRI
      WRITE(*,*) ABS (NCASE)
      MCASE  = 0
      GO TO 200
 110  CONTINUE
      REWIND 1
      IRECRD = 0
      READ (1) RUNTIT, RUNTIM, WEIPRI, NCASE
      IRECRD = IRECRD + 1
      WRITE (*,*) RUNTIT
      WRITE (*,*) RUNTIM
      WRITE (*,*) WEIPRI
      WRITE (*,*) ABS (NCASE)
      MCASE  = 0
      NBATCH = 1
 200  CONTINUE
      LOFFEV = INDEX ( RUNTIM, 'Time Evolution' ) .GT. 0
      IF ( NCASE * MCASE .LT. 0 ) STOP ' INVALID NCASE/MCASE'
      LEVOLN = LOFFEV .OR. ( NCASE .LT. 0 .OR. MCASE .LT. 0 )
      LOLDIR = NCASE  .GE. 0 .AND. MCASE .GE. 0
      NCASE  = ABS (NCASE)
      MCASE  = ABS (MCASE)
      IF ( LEVOLN ) THEN
         IF ( LOLDIR ) THEN
            READ (1) BEAINT, TIMEIR
            IRECRD = IRECRD + 1
            NIRRDT = 1
            BIRRDT (1) = BEAINT
            TIRRDT (1) = TIMEIR
         ELSE
            READ (1) NIRRDT, ( BIRHLP(IR), TIRHLP(IR), IR = 1, NIRRDT )
            IRECRD = IRECRD + 1
            BEAINT = ZERZER
            TPREV  = ZERZER
            DO IR = 1, NIRRDT
               BIRRDT (IR) = BIRHLP (IR)
               TIRRDT (IR) = TIRHLP (IR)
               BEAINT = BEAINT + BIRRDT (IR) * ( TIRRDT (IR) - TPREV )
               TPREV  = TIRRDT (IR)
            END DO
            TIMEIR = TIRRDT (NIRRDT)
            BEAINT = BEAINT / TIMEIR
         END IF
         WRITE (*,*) ' Intensity:', BEAINT, ' pr/s'
         WRITE (*,*) ' T_irrad. :', TIMEIR, ' s'
      END IF
      NCTOT  = NCTOT + NCASE
      MCTOT  = MCTOT + MCASE
      IF ( NCTOT .GE. 1000000000 ) THEN
         NCTOT = NCTOT - 1000000000
         MCTOT = MCTOT + 1
      END IF
      WCTOT  = WCTOT  + DBLE (WEIPRI)
      MBATCH = MBATCH + NBATCH
      KLAST  = 0
      KMAX   = 0
      NRNDC  = 0
      MRNDC  = 0
      NRNMN  = 0
*  +-------------------------------------------------------------------*
*  |                            Read from binary file the results!!!
      DO 6600 IX = 1,1000
         NRN = IX - NRNMN
         READ (1,ERR=6350,END=1000) CHSTAT,IJX
         IRECRD = IRECRD + 1
         IF ( CHSTAT .EQ. 'STATISTICS') THEN
            LSTATI = .TRUE.
            NRNDC  = MRNDC
            IF ( .NOT. LEVOLN ) GO TO 1000
            NRNMN = NRNMN + 1
            DO J = 1, NRNDC
               READ (1)
               READ (1)
               READ (1)
               READ (1)
               READ (1)
               READ (1)
               IRECRD = IRECRD + 6
               IF ( LISMRS ) THEN
                  READ (1)
                  IRECRD = IRECRD + 1
               END IF
            END DO
            MRNDC = 0
            GO TO 6600
         END IF
         IRECRD = IRECRD - 1
 6350    CONTINUE
*        BACKSPACE 1
         REWIND 1
         DO IR = 1, IRECRD
            READ (1)
         END DO
         READ (1,ERR=6400,END=1000)
     &                MRN, TIURSN(NRN), ITURSN(NRN), NRURSN(NRN),
     &                VURHLP, IMRHGH (NRN), IZRHGH (NRN), NMZMNM
         IRECRD = IRECRD + 1
         VURSNC (NRN) = VURHLP
         IF ( LEVOLN ) READ (1) TDECAY (NRN)
         IF ( LEVOLN ) IRECRD = IRECRD + 1
         GO TO 6500
 6400    CONTINUE
*        BACKSPACE 1
         REWIND 1
         DO IR = 1, IRECRD
            READ (1)
         END DO
         READ (1,ERR=6450) CHSTAT,IJX
         IRECRD = IRECRD + 1
         IF ( CHSTAT .EQ. 'STATISTICS') THEN
            LSTATI = .TRUE.
            NRNDC  = MRNDC
            IF ( .NOT. LEVOLN ) GO TO 1000
            NRNMN = NRNMN + 1
            DO J = 1, NRNDC
               READ (1)
               READ (1)
               READ (1)
               READ (1)
               READ (1)
               READ (1)
               IRECRD = IRECRD + 6
               IF ( LISMRS ) THEN
                  READ (1)
                  IRECRD = IRECRD + 1
               END IF
            END DO
            MRNDC = 0
            GO TO 6600
         END IF
 6450    CONTINUE
         STOP ' 2ND-RECORD'
 6500    CONTINUE
         JX (IX-NRNMN) = NRN
         NRNMX   = NRN
         MRNDC   = MRNDC + 1
***************************************************************
*********** Note KBURSN is used for 0 address *****************
***************************************************************
         KBURSN (NRN) = KLAST
         K0     = KLAST + 1
         K1     = IMRHGH (NRN) * IZRHGH (NRN) + K0 - 1
         KLAST  = K1
         READ (1) (GMSTOR(J), J = K0, K1)
         IRECRD = IRECRD + 1
         KMAX   = MAX ( KMAX, K1 )
         READ (1,ERR=6530,END=6525) CHISMR,NISMRS(NRN)
         IRECRD = IRECRD + 1
         IF ( CHISMR .EQ. 'ISOMERS:  ' ) THEN
            KI0   = K1 + 1
            KI1   = K1 + NISMRS (NRN)
            KLAST = KI1
            KMAX  = MAX ( KMAX, KI1 )
*           WRITE (*,*) ' ISOMERS: KI0, KI1', KI0, KI1
            IF ( KI1 .GE. KI0 ) THEN
               READ (1) (GMSTOR(J), J = KI0, KI1)
*              WRITE (*,*) ' (GMSTOR(J), J = KI0, KI1)',
*    &                       (GMSTOR(J), J = KI0, KI1)
            ELSE
               READ (1)
            END IF
            IRECRD = IRECRD + 1
            LISMRS = .TRUE.
            GO TO 6535
         ELSE
*           WRITE (*,*) ' CHISMR  ', CHISMR
            NISMRS(NRN) = 0
            IRECRD = IRECRD - 1
            GO TO 6530
         END IF
 6525    CONTINUE
         LFIEND = .TRUE.
 6530    CONTINUE
*        BACKSPACE 1
         REWIND 1
         DO IR = 1, IRECRD
            READ (1)
         END DO
         KI1    = K1
 6535    CONTINUE
         DO J = K0, KI1
            GDSTOR (J) = GDSTOR(J) + DBLE (GMSTOR(J))   
     &                 * ( DBLE (NCASE) + DBLE (MCASE) * 1.D+09 )
            GBSTOR (J) = GBSTOR(J) + DBLE (GMSTOR(J))**2
     &                 * ( DBLE (NCASE) + DBLE (MCASE) * 1.D+09 )
         END DO
         KMAX = MAX ( KMAX, KI1 )
         IF ( LFIEND ) GO TO 1000
 6600 CONTINUE
*  |
*  +-------------------------------------------------------------------*
 1000 CONTINUE
      IX = NRNMX
      IF ( NRNDC .EQ. 0 ) NRNDC = NRNMX
      WRITE (*,*) ' Nrnmx:', NRNMX
*  +-------------------------------------------------------------------*
*  |  First run: allocate the room for A-mass yields:
      IF ( MBATCH .EQ. 1 ) THEN
         DO IIX = 1, IX
            NRN   = JX (IIX)
            KAURSN (NRN) = KLAST
            KLAST = KLAST + IMRHGH (NRN) + 2 * IZRHGH (NRN) + NMZMNM
            KZURSN (NRN) = KLAST
            KLAST = KLAST + IZRHGH (NRN)
            KMAX  = MAX ( KMAX, KLAST )
         END DO
         FILE1 = FILE
         LQOLD = LQ
      END IF
*  |
*  +-------------------------------------------------------------------*
      CLOSE (UNIT=1)
      KLAST = 0
*  +-------------------------------------------------------------------*
*  |  Loop over the scorings:
      DO 7000 IIX = 1, IX
         NRN    = JX (IIX)
         ACCUMP = ZERZER
*  |  +----------------------------------------------------------------*
*  |  |
         DO IG  = 1, IMRHGH (NRN) + 2 * IZRHGH (NRN) + NMZMNM
            ACCUMA (IG) = ZERZER
            ACCUMZ (IG) = ZERZER
         END DO
*  |  |
*  |  +----------------------------------------------------------------*
         AFACT = DBLE (NCASE) + DBLE (MCASE) * 1.D+09
         K0    = KLAST + 1
         K1    = IMRHGH (NRN) * IZRHGH (NRN) + K0 - 1
         KLAST = K1
*        close (unit=98)
*        jc    = k0-1
*  |  +----------------------------------------------------------------*
*  |  |
         DO 6540 IM = 1, IMRHGH (NRN)
*  |  |  +-------------------------------------------------------------*
*  |  |  |
            DO 6520 IZ = 1, IZRHGH (NRN)
               IN  = IM + IZ + NMZMNM
               IA  = IN + IZ
               IZN = IZ + IZRHGH (NRN) * ( IM - 1 ) + KBURSN (NRN)
               KK0 = IZN
               KMAX   = MAX ( KMAX, KK0 )
               DSCORE = DBLE ( GMSTOR (IZN) )
               IF ( IZN .GT. K1 ) STOP ' IZN>K1'
               IF ( IA  .LT.  1 ) GO TO 6520
               ACCUMP = ACCUMP + DSCORE
*              jc  = jc + 1
*              write(98,*) jc,dscore
               ACCUMA (IA) = ACCUMA (IA) + DSCORE
               ACCUMZ (IZ) = ACCUMZ (IZ) + DSCORE
 6520       CONTINUE
*  |  |  |
*  |  |  +-------------------------------------------------------------*
 6540    CONTINUE
*  |  |
*  |  +----------------------------------------------------------------*
         KI0   = K1 + 1
         KI1   = K1 + NISMRS (NRN)
         KLAST = KI1
*  |  +----------------------------------------------------------------*
*  |  |  Loop over possible isomers:
         DO 6550 KS = 1, NISMRS (NRN)
            IZN = KS - 1 + KI0
            IF ( IZN .GT. KI1 ) STOP ' IZN>KI1'
            IF ( GMSTOR (IZN) .GT. 0.E+00 ) THEN
               CALL ISMRCH ( IA, IZ, IS, KS, ADUMMY, BDUMMY, JDUMMY,
     &                       IDUMMY )
               DSCORE = DBLE ( GMSTOR (IZN) )
               IF ( IA .LT. 1 ) GO TO 6550
               ACCUMP = ACCUMP + DSCORE
*              jc  = jc + 1
*              write(98,*) jc,dscore
               ACCUMA (IA) = ACCUMA (IA) + DSCORE
               ACCUMZ (IZ) = ACCUMZ (IZ) + DSCORE
            END IF
 6550    CONTINUE
*  |  |
*  |  +----------------------------------------------------------------*
         TOTTOT (NRN) = TOTTOT (NRN) + ACCUMP * AFACT
         TOTERR (NRN) = TOTERR (NRN) + ACCUMP * ACCUMP * AFACT
*  |  +----------------------------------------------------------------*
*  |  |
         DO IA = 1, IMRHGH (NRN) + 2 * IZRHGH (NRN) + NMZMNM
            KK0 = KAURSN (NRN) + IA
            GDSTOR (KK0) = GDSTOR (KK0) + ACCUMA (IA) * AFACT
            GBSTOR (KK0) = GBSTOR (KK0) + ACCUMA (IA) * ACCUMA (IA)
     &                   * AFACT
            KMAX = MAX ( KMAX, KK0 )
         END DO
*  |  |
*  |  +----------------------------------------------------------------*
*  |  +----------------------------------------------------------------*
*  |  |
         DO IZ = 1, IZRHGH (NRN)
            KK0 = KZURSN (NRN) + IZ
            GDSTOR (KK0) = GDSTOR (KK0) + ACCUMZ (IZ) * AFACT
            GBSTOR (KK0) = GBSTOR (KK0) + ACCUMZ (IZ) * ACCUMZ (IZ)
     &                   * AFACT
            KMAX = MAX ( KMAX, KK0 )
         END DO
*  |  |
*  |  +----------------------------------------------------------------*
         KMAX = MAX ( KMAX, KK0 )
7000  CONTINUE
*  |
*  +-------------------------------------------------------------------*
**sr bug patch
      DO J = K0, KI1
         GMSTOR (J) = 0.0E+00
      END DO
**
      GO TO 1111
2000  CONTINUE
*  +-------------------------------------------------------------------*
*  |
      DO J = 1, KMAX
         GDSTOR (J) = GDSTOR (J)
     &              / ( DBLE (NCTOT) + DBLE (MCTOT) * 1.D+09 )
         GBSTOR (J) = GBSTOR (J)
     &              / ( DBLE (NCTOT) + DBLE (MCTOT) * 1.D+09 )
      END DO
*  |
*  +-------------------------------------------------------------------*
*  +-------------------------------------------------------------------*
*  |
      DO IIX = 1, IX
         NRN = JX (IIX)
         TOTTOT (NRN) = TOTTOT (NRN)
     &                / ( DBLE (NCTOT) + DBLE (MCTOT) * 1.D+09 )
         TOTERR (NRN) = TOTERR (NRN)
     &                / ( DBLE (NCTOT) + DBLE (MCTOT) * 1.D+09 )
      END DO
*  |
*  +-------------------------------------------------------------------*
*  +-------------------------------------------------------------------*
*  |  Real sum of Mbatch runs:
      IF ( MBATCH - 1 .GT. 0 ) THEN
         DO J = 1, KMAX
            GBSTOR (J) = SQRT ( GBSTOR (J) )
            GBSTOR (J) = ( GBSTOR (J) - GDSTOR (J) )
     &                 * ( GBSTOR (J) + GDSTOR (J) )
     &                 / DBLE (MBATCH-1)
            IF ( ABS ( GBSTOR (J) ) .LT. 1.D-12 * GDSTOR (J)**2 )
     &         GBSTOR (J) = ZERZER
            IF ( GDSTOR (J) .GT. ZERZER ) THEN
               GBSTOR (J) = MIN ( SQRT ( GBSTOR (J) ) / GDSTOR (J),
     &                            0.99D+00 )
            END IF
         END DO
         DO IIX = 1, IX
            NRN = JX (IIX)
            TOTERR (NRN) = SQRT (TOTERR(NRN))
            TOTERR (NRN) = ( TOTERR (NRN) - TOTTOT (NRN) )
     &                   * ( TOTERR (NRN) + TOTTOT (NRN) )
     &                   / DBLE (MBATCH-1)
            IF ( ABS ( TOTERR (NRN) ) .LT. 1.D-12 * TOTTOT (NRN)**2 )
     &              TOTERR (NRN) = ZERZER
            IF ( TOTTOT (NRN) .GT. ZERZER ) THEN
               TOTERR (NRN) = MIN ( SQRT ( TOTERR(NRN) ) / TOTTOT (NRN),
     &                              0.99D+00)
            END IF
         END DO
         LSTATI = .FALSE.
*  |
*  +-------------------------------------------------------------------*
*  |  Only one run, check if it is already a sum with statistics:
      ELSE IF ( LSTATI ) THEN
         OPEN ( UNIT=11, FILE=FILE1, STATUS='OLD', FORM='UNFORMATTED' )
         READ (11)
         IF ( LEVOLN ) READ (11)
         KLAST = 0
         DO JJX = 1, IX / NRNDC
            DO JIX = 1, NRNDC
               READ (11)
               IF ( LEVOLN ) READ (11)
               READ (11)
               IF ( LISMRS ) THEN
                  READ (11)
                  READ (11)
               END IF
            END DO
            READ (11) CHSTAT,IJX
            IF ( CHSTAT .NE. 'STATISTICS' .OR. IJX .NE. NRNDC )
     &        STOP 'STATI'
            DO 7400 JIX = 1, NRNDC
               IIX = (JJX-1)*NRNDC + JIX
               NRN = JX (IIX)
               READ (11) TOTA, TOTB
               IF ( ABS (TOTA-TOTTOT(NRN)) .GT. 1.D-05*TOTA )
     &            WRITE (*,*)' *** Error Tota:',TOTA,TOTTOT(NRN)
               TOTERR (NRN) = TOTB
               KK0 = 1
               KK1 = IMRHGH (NRN) + 2 * IZRHGH (NRN) + NMZMNM
               READ (11) ( RCCUMA (J), J = KK0, KK1 )
               IF ( .NOT. LEVOLN ) THEN
                  DO 7100 J = KK0, KK1
                     IF ( ABS (RCCUMA(J)-GDSTOR(J+KAURSN(NRN))) .GT.
     &                    1.D-05*RCCUMA(J) )
     &               WRITE (*,*)' *** Error Gdstor:',RCCUMA(J),
     &                            GDSTOR(J+KAURSN(NRN))
 7100             CONTINUE
               END IF
               READ (11) ( RCCUMA (J), J = KK0, KK1 )
               DO 7150 J = KK0, KK1
                  GBSTOR (J+KAURSN(NRN)) = RCCUMA (J)
 7150          CONTINUE
               KK0 = 1
               KK1 = IZRHGH (NRN)
               READ (11) ( RCCUMZ (J), J = KK0, KK1 )
               IF ( .NOT. LEVOLN ) THEN
                  DO 7200 J = KK0, KK1
                     IF ( ABS (RCCUMZ(J)-GDSTOR(J+KZURSN(NRN))) .GT.
     &                    1.D-05*RCCUMZ(J) )
     &               WRITE (*,*)' *** Error Gdstor:',RCCUMZ(J),
     &                            GDSTOR(J+KZURSN(NRN))
 7200             CONTINUE
               END IF
               READ (11) ( RCCUMZ (J), J = KK0, KK1 )
               DO 7250 J = KK0, KK1
                  GBSTOR (J+KZURSN(NRN)) = RCCUMZ (J)
 7250          CONTINUE
               K0    = KLAST + 1
               K1    = IMRHGH (NRN) * IZRHGH (NRN) + K0 - 1
               KLAST = K1
               READ (11) ( GMSTOR(J), J = K0, K1 )
               DO 7300 J = K0, K1
                  GBSTOR (J) = DBLE (GMSTOR(J))
 7300          CONTINUE
               IF ( LISMRS ) THEN
                  KI0   = KLAST + 1
                  KI1   = KLAST + NISMRS (NRN)
                  KLAST = KI1
                  IF ( NISMRS (NRN) .GT. 0 ) THEN
                     READ (11) ( GMSTOR(J), J = KI0, KI1 )
                  ELSE
                     READ (11)
                  END IF
                  DO 7350 J = KI0, KI1
                     GBSTOR (J) = DBLE (GMSTOR(J))
 7350             CONTINUE
               END IF
 7400       CONTINUE
         END DO
         KLAST = 0
         CLOSE ( UNIT=11 )
*  |
*  +-------------------------------------------------------------------*
*  |  Only one plain run, no possibility of making statistics:
      ELSE
         LSTATI = .FALSE.
         DO J = 1, KMAX
            IF ( GDSTOR(J) .GT. ZERZER ) THEN
               GBSTOR (J) = 0.99D+00
            END IF
         END DO
         DO IIX = 1, IX
            NRN = JX (IIX)
            IF ( TOTTOT (NRN) .GT. ZERZER ) THEN
               TOTERR (NRN) = 0.99D+00
            END IF
         END DO
      END IF
*  |
*  +-------------------------------------------------------------------*
*  +-------------------------------------------------------------------*
*  |  If 1 run already with statistics, no need to create a new output
      IF ( .NOT. LSTATI ) THEN
         IF ( LEVOLN ) THEN
            RUNTIM='   ***** Time Evolution *****'
         ELSE
            RUNTIM='      ***** Sum file *****'
         END IF
         WRITE(*,*)' Type the output file name:'
         READ (*,'(A)') FILE
         LQ=LNNBLN(FILE)
* Start_UNIX_seq
         OPEN (UNIT=1,FILE=FILE,STATUS='UNKNOWN',FORM='UNFORMATTED')
* End_UNIX_seq
* Start_VAX_seq
*        OPEN (UNIT=1,FILE=FILE,STATUS='NEW',FORM='UNFORMATTED')
* End_VAX_seq
         IF ( LEVOLN ) THEN
            WRITE (1) RUNTIT, RUNTIM, SNGL(WCTOT),-NCTOT,-MCTOT, MBATCH
            WRITE (1) NIRRDT, ( SNGL(BIRRDT(IR)), SNGL(TIRRDT(IR)),
     &                          IR = 1, NIRRDT )
         ELSE
            WRITE (1) RUNTIT, RUNTIM, SNGL(WCTOT), NCTOT, MCTOT, MBATCH
         END IF
*  |
*  +-------------------------------------------------------------------*
*  |
      ELSE
         FILE = FILE1
         LQ   = LQOLD
      END IF
*  |
*  +-------------------------------------------------------------------*
      KLAST = 0
*  +-------------------------------------------------------------------*
*  |  Loop over scorings:
      DO 6800 JJ=1,IX
         NRN   = JX(JJ)
         IF ( .NOT. LSTATI )
     &   WRITE (1)    NRN, TIURSN(NRN), ITURSN(NRN), NRURSN(NRN),
     &                VURSNC (NRN), IMRHGH(NRN), IZRHGH(NRN), NMZMNM
         IF ( LEVOLN .AND. .NOT. LSTATI ) WRITE (1) TDECAY (NRN)
         K0    = KLAST + 1
         K1    = IMRHGH (NRN) * IZRHGH (NRN) + K0 - 1
         KLAST = K1
         IF ( .NOT. LSTATI )
     &   WRITE (1) (SNGL(GDSTOR(J)), J = K0, K1)
         IF ( .NOT. LSTATI .AND. LISMRS ) THEN
            WRITE (1) 'ISOMERS:  ', NISMRS (NRN)
            KI0   = KLAST + 1
            KI1   = KLAST + NISMRS (NRN)
            KLAST = KI1
            IF ( KI1 .GE. KI0 ) THEN
               WRITE (1) (SNGL(GDSTOR(J)), J = KI0, KI1)
            ELSE
               WRITE (1)
            END IF
         END IF
6800  CONTINUE
*  |
*  +-------------------------------------------------------------------*
*  Now write the statistical data, first a record to flag them
      IF ( .NOT. LSTATI ) WRITE (1) 'STATISTICS',IX
*  Then the errors concerning the binning data
      KLAST = 0
      INDX  = INDLST ( FILE, '.' )
      IF ( INDX .GT. 0 ) THEN
* Start_UNIX_seq
         OPEN (UNIT=3,FILE=FILE(1:INDX-1)//'_sum.lis',STATUS='UNKNOWN')
* End_UNIX_seq
* Start_VAX_seq
*        OPEN (UNIT=3,FILE=FILE(1:INDX-1)//'_sum.lis',STATUS='NEW',
*    &         CARRIAGECONTROL='LIST')
* End_VAX_seq
      ELSE
* Start_UNIX_seq
         OPEN (UNIT=3,FILE=FILE(1:LQ)//'_sum.lis',STATUS='UNKNOWN')
* End_UNIX_seq
* Start_VAX_seq
*        OPEN (UNIT=3,FILE=FILE(1:LQ)//'_sum.lis',STATUS='NEW',
*    &         CARRIAGECONTROL='LIST')
* End_VAX_seq
      END IF
* Start_VAX_seq
*     IF ( INDX .GT. 0 ) THEN
*        OPEN (UNIT=4,FILE=FILE(1:INDX-1)//'_TAB.LIS',STATUS='NEW',
*    &         CARRIAGECONTROL='LIST')
*     ELSE
*        OPEN (UNIT=4,FILE=FILE(1:LQ)//'_TAB.LIS',STATUS='NEW',
*    &         CARRIAGECONTROL='LIST')
*     END IF
* End_VAX_seq
* Start_UNIX_seq
      IF ( INDX .GT. 0 ) THEN
         OPEN (UNIT=4,FILE=FILE(1:INDX-1)//'_tab.lis',STATUS='UNKNOWN')
      ELSE
         OPEN (UNIT=4,FILE=FILE(1:LQ)//'_tab.lis',STATUS='UNKNOWN')
      END IF
* End_UNIX_seq
      WRITE (3,*)' **** ',FILE(1:LQ),' ****'
      WRITE (3,*)
      WRITE (3,*)
      WRITE (CHCTOT,'(F15.0)') DBLE (NCTOT) + DBLE (MCTOT) * 1.D+09
      WRITE (3,'(A,2X,A14)')'  Total primaries run:',CHCTOT
      WRITE (3,*)
      WRITE (3,*)'   Total weight of the primaries run:',SNGL(WCTOT)
      WRITE (3,*)
*  +-------------------------------------------------------------------*
*  |  Loop over scorings:
      DO 6850 JJ = 1, IX
         NRN = JX(JJ)
         IF ( .NOT. LSTATI )
     &   WRITE (1) SNGL(TOTTOT(NRN)),SNGL(TOTERR(NRN))
         IF ( LEVOLN ) THEN
            WRITE (3,*)
            WRITE (3,*) ' Beam intensity  :',BEAINT,' pr/s'
            WRITE (3,*)
            WRITE (3,*) ' Irradiation time:',TIMEIR,' s'
            WRITE (3,*)
            WRITE (3,*) ' Decay time      :',TDECAY(NRN),' s'
         END IF
         WRITE (3,*)
         WRITE (3,*) ' Detector n: ', NRN,'  ',TIURSN (NRN)
         WRITE (3,*) '    (Region',NRURSN(NRN),' Volume:  ',
     &                     VURSNC(NRN),' cmc,'
         WRITE (3,*) '     distr. type  :',ITURSN(NRN),'   ,'
         WRITE (3,*) '     Z_max:',IZRHGH(NRN),', N-Z_max:',
     &                     IMRHGH(NRN)+NMZMNM,', N-Z_min:',NMZMNM+1,
     &               ')'
         WRITE (3,*)
         IF ( LEVOLN ) THEN
            WRITE (3,*)'    Tot. response (Bq/cmc)', SNGL(TOTTOT(NRN)),
     &                 '  +/-',SNGL(TOTERR(NRN))*100.0,' %'
            WRITE (3,*)'    ( --> Bq              ',
     &                         SNGL(TOTTOT(NRN)*VURSNC(NRN)),
     &                 '  +/-',SNGL(TOTERR(NRN))*100.0,' % )'
         ELSE
            WRITE (3,*)'    Tot. response (n/cmc/pr)',SNGL(TOTTOT(NRN)),
     &                 '  +/-',SNGL(TOTERR(NRN))*100.0,' %'
            WRITE (3,*)'    ( --> Nuclei/pr         ',
     &                         SNGL(TOTTOT(NRN)*VURSNC(NRN)),
     &                 '  +/-',SNGL(TOTERR(NRN))*100.0,' % )'
         END IF
         WRITE (3,*)
         WRITE (4,'(A,I5,A)') '# Detector n: ', NRN,'  ',TIURSN (NRN)
         KK0 = KAURSN (NRN) + 1
         KK1 = KAURSN (NRN) + IMRHGH (NRN) + 2 * IZRHGH (NRN) + NMZMNM
         IF ( .NOT. LEVOLN ) THEN
            WRITE (3,*)
     &         ' **** Isotope Yield as a function of Mass Number ****',
     &         ' ****            (nuclei / cmc / pr)             ****'
            WRITE (3,*)
            WRITE (3,*)
            WRITE (3,*)
     &         ' A_min:',1,' -  A_max:',IMRHGH(NRN) + 2*IZRHGH(NRN)
     &                                + NMZMNM
            WRITE (3,*)
            WRITE (4,'(A,2I5)') '# A_min-A_max' ,1,IMRHGH(NRN)
     &                                         + 2*IZRHGH(NRN) + NMZMNM
            DO J = KK1, KK0, -1
               IA = J - KK0 + 1
               IF ( GDSTOR(J) .GT. AZRZRZ .AND. IA .GE. 1 )
     &         WRITE (3,8310) IA, GDSTOR(J), GBSTOR(J)*100.D+00
               IF ( IA .GE. 1 )
     &            WRITE (4,'(I5,1P,2G12.4)')
     &                   IA, GDSTOR(J), GBSTOR(J)*100.D+00
            END DO
         END IF
 8310    FORMAT (1X,' A: ',I12,1X,1P,E14.7,' +/- ',1X,E14.7,' %')
         IF ( .NOT. LSTATI ) THEN
            WRITE (1) ( SNGL (GDSTOR(J)), J = KK0, KK1 )
            WRITE (1) ( SNGL (GBSTOR(J)), J = KK0, KK1 )
         END IF
         WRITE (3,*)
         KK0 = KZURSN (NRN) + 1
         KK1 = KZURSN (NRN) + IZRHGH (NRN)
         IF ( .NOT. LEVOLN ) THEN
            WRITE (3,*)
     &       ' **** Isotope Yield as a function of Atomic Number ****',
     &       ' ****            (nuclei / cmc / pr)               ****'
            WRITE (3,*)
            WRITE (3,*)
            WRITE (3,*) ' Z_min:',1,' -  Z_max:',IZRHGH(NRN)
            WRITE (3,*)
            WRITE (4,*) '# Z_min-Z_max' ,1,IZRHGH(NRN)
            DO J = KK1, KK0, -1
               IZ = J - KK0 + 1
               IF ( GDSTOR(J) .GT. AZRZRZ )
     &         WRITE (3,8320) IZ, GDSTOR(J), GBSTOR(J)*100.D+00
               WRITE (4,'(I5,1P,2G12.4)')
     &                IZ, GDSTOR(J), GBSTOR(J)*100.D+00
            END DO
         END IF
 8320    FORMAT (1X,' Z: ',I12,1X,1P,E14.7,' +/- ',1X,E14.7,' %')
         IF ( .NOT. LSTATI ) THEN
            WRITE (1) ( SNGL (GDSTOR(J)), J = KK0, KK1 )
            WRITE (1) ( SNGL (GBSTOR(J)), J = KK0, KK1 )
         END IF
         K0 = KLAST + 1
         K1 = IMRHGH (NRN) * IZRHGH (NRN) + K0 - 1
         KLAST = K1
         IF ( .NOT. LSTATI )
     &   WRITE (1) (SNGL(GBSTOR(J)), J = K0, K1)
         WRITE (3,*)
         IF ( LEVOLN ) THEN
            WRITE (3,*)
     &            ' **** Residual nuclei distribution  ****',
     &            ' ****           (Bq/cmc)            ****'
         ELSE
            WRITE (3,*)
     &            ' **** Residual nuclei distribution  ****',
     &            ' ****    (nuclei / cmc / pr)        ****'
         END IF
         WRITE (3,*)
         WRITE (3,*)
         WRITE (4,'(A)') '# A/Z Isotopes:'
         DO IA = 1, MXARSN
            DO IZ = 1, 100
               RESNUC (IZ,IA) = 0.E+00
               RESERR (IZ,IA) = 0.E+00
               IABEG  (IZ) = 500
               IAEND  (IZ) = 0
            END DO
         END DO
         DO IM = 1, IMRHGH (NRN)
            DO IZ  = 1, IZRHGH (NRN)
               IN  = IM + IZ + NMZMNM
               IA  = IN + IZ
               IF ( IA .GE. 1 ) THEN
                  IZN = K0 - 1 + ( IM - 1 ) * IZRHGH (NRN) + IZ
                  RESNUC (IZ,IA) = GDSTOR (IZN)
                  IF ( ABS (GDSTOR (IZN)) .GT. 0.E+00 ) THEN
                     IABEG (IZ) = MIN ( IABEG (IZ), IA )
                     IAEND (IZ) = MAX ( IAEND (IZ), IA )
                     RESERR (IZ,IA) = GBSTOR (IZN) * 100.D+00
                  END IF
               END IF
            END DO
         END DO
         IASTRT = IMRHGH (NRN) + 2 * IZRHGH (NRN) + NMZMNM
         IZ0    = IZRHGH (NRN) + 1
 9220    CONTINUE
         IZ1 = IZ0 - 1
         IZ0 = MAX ( 1, IZ1 - 10 )
*        IAS1= IASTLN (MIN(MAX(IZ1,1),100))
*        IAS0= IASTLN (MIN(MAX(IZ0,1),100))
*        IA1 = MIN ( IASTRT, IAS1 + MAX ( MIN (IZ1/5,10),  5 ) )
*        IA0 = MAX ( IZ0   , IAS0 - MAX ( MIN (IZ1/3,20), 10 ) )
*        IA1 = MIN ( IA1, IMRHGH (NRN) + 2 * IZ1 + NMZMNM )
*        IA0 = MAX ( IA0, 1 + 2 * IZ0 + NMZMNM )
*        IA0 = MAX ( IA0, 1 )
         IA1 = 0
         IA0 = 500
         DO IZ = IZ0, IZ1
            IA1 = MAX ( IA1, IAEND (IZ) )
            IA0 = MIN ( IA0, IABEG (IZ) )
         END DO
         WRITE (3,9240) ( IZ, IZ = IZ0, IZ1 )
         DO 9230 IA = IA1, IA0, - 1
            LCHECK = .FALSE.
            DO IZ = IZ0, IZ1
               LCHECK = LCHECK .OR. RESNUC (IZ,IA) .GE. 2.E-38
            END DO
            IF ( LCHECK ) THEN
            WRITE (3,9250) IA, ( RESNUC (IZ,IA), IZ = IZ0, IZ1 )
            WRITE (3,9260)     ( CHERR, RESERR (IZ,IA), IZ = IZ0, IZ1 )
            END IF
            WRITE (4,'(2I5,1P,2G12.4)') ( IA, IZ, RESNUC (IZ,IA),
     &                                    RESERR (IZ,IA), IZ = IZ0, IZ1)
 9230    CONTINUE
         IF ( IZ0 .GT. 1 ) GO TO 9220
* Start_VAX_seq
*9240    FORMAT ( /, 1X,' A \ Z',2X,I3,3X,10(5X,I3,3X) )
* End_VAX_seq
* Start_UNIX_seq
 9240    FORMAT ( /, 1X,' A \\ Z',2X,I3,3X,10(5X,I3,3X) )
* End_UNIX_seq
 9250    FORMAT ( 1X,I3,11(3X,1P,E8.2) )
 9260    FORMAT ( 1X,3X,11(2X,A3,F4.1,' %') )
         WRITE (3,*)
         WRITE (3,*)
         IF ( LISMRS ) THEN
            WRITE (4,'(A)') '# A/Z/m Isomers:'
            KI0   = KLAST + 1
            KI1   = KLAST + NISMRS (NRN)
            KLAST = KI1
            IF ( .NOT. LSTATI ) THEN
               IF ( NISMRS (NRN) .GT. 0 ) THEN
                  WRITE (1) (SNGL(GBSTOR(J)),J=KI0,KI1)
               ELSE
                  WRITE (1)
               END IF
            END IF
            IF ( NISMRS (NRN) .GT. 0 ) THEN
               IF ( LEVOLN ) THEN
                  WRITE (3,*)
     &                  ' **** Isomers (Bq/cmc)     ****'
                  WRITE (3,*) '     A        Z       mth'
               ELSE
                  WRITE (3,*)
     &                  ' **** Isomers (nuclei / cmc / pr)     ****'
                  WRITE (3,*) '     A        Z       mth'
               END IF
            END IF
            DO KS = 1, NISMRS (NRN)
               IZN = KI0 + KS - 1
               IF ( GDSTOR(IZN) .GT. AZRZRZ ) THEN
                  CALL ISMRCH ( IA, IZ, IS, KS, ADUMMY, BDUMMY, JDUMMY,
     &                          IDUMMY )
                  WRITE (3,9270) IA, IZ, IS, SNGL(GDSTOR(IZN)),
     &                               SNGL(GBSTOR(IZN)*100.D+00)
 9270             FORMAT(1X,I8,I8,I8,4X,1P,E8.2,' +/- ',0P,F4.1,' %')
                  WRITE (4,'(3I5,1P,2G12.4)') IA, IZ, IS, GDSTOR (IZN),
     &                                        GBSTOR (IZN)*100.D+00
               END IF
            END DO
            WRITE (3,*)
         END IF
 6850 CONTINUE
*  |
*  +-------------------------------------------------------------------*
      IF ( .NOT. LSTATI ) CLOSE (UNIT=1)
      STOP
      END

*$ CREATE ISOINI.FOR
*COPY ISOINI
*
*=== isoini ===========================================================*
*
      SUBROUTINE ISOINI

      INCLUDE '(DBLPRC)'
      INCLUDE '(DIMPAR)'
      INCLUDE '(IOUNIT)'
*
*----------------------------------------------------------------------*
*                                                                      *
*     Created on 19 september 1995 by    Alfredo Ferrari & Paola Sala  *
*                                                   Infn - Milan       *
*                                                                      *
*     Last change on 03-Nov-96     by    Alfredo Ferrari               *
*                                                                      *
*                                                                      *
*----------------------------------------------------------------------*
*
      INCLUDE '(PAREVT)'
*  === Block data === *
      EXTERNAL BDNOPT,BDEVAP,BDINPT
*
      CALL CMSPPR
      LEVPRT = .TRUE.
      LDEEXG = .TRUE.
      LHEAVY = .TRUE.
      IFISS  = 1
      CALL NCDTRD
      RETURN
      END

*$ CREATE ISMHLP.FOR
*COPY ISMHLP
*
*=== ismhlp ===========================================================*
*
      INTEGER FUNCTION ISMHLP (IA)

      INCLUDE '(DBLPRC)'
      INCLUDE '(DIMPAR)'
      INCLUDE '(IOUNIT)'
*
*----------------------------------------------------------------------*
*                                                                      *
*     Created on 19 september 1995 by    Alfredo Ferrari & Paola Sala  *
*                                                   Infn - Milan       *
*                                                                      *
*     Last change on 03-Nov-96     by    Alfredo Ferrari               *
*                                                                      *
*                                                                      *
*----------------------------------------------------------------------*
*
      INCLUDE '(ISOTOP)'
*
      ISMHLP = INWISM (IA)
      RETURN
      END

