*DECK D2PBRA
      SUBROUTINE D2PBRA(IPDAT,IPINP,IPHEL,STAVEC,JOBOPT,DEB,IPRINT)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Recover information from the INFO data block for a complete branch
* and write it in the IPHEL file . The format of this file is described
* in the DRAG2PARCS: manual. This routine write sequentially the IPHEL
* file, branch after branch
*
*Author(s): J. Taforeau
*
*parameters: input
* IPDAT   address of info data block
* IPINP   file unit of the input file GENPMAXS.inp
* IPHEL   file unit of the HELIOS.dra file
* STAVEC  various parameters associated with the IPDAT structure
* JOBOPT  flag for JOB_OPT record in IPINP object
* DEB     flag for D2PGEN
* IPRINT  control the printing on screen
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPDAT
      INTEGER IPINP,IPHEL,STAVEC(40),DEB,IPRINT
      CHARACTER(len=4) JOBOPT(14)
*----
*  LOCAL VARIABLES
*----
      INTEGER GRID,ITBRAN,NVAR
      INTEGER NSF,NGP,NXS,NBU,FLPRIN
      INTEGER STAIDX(STAVEC(2))
      INTEGER IUPS,FA_K,NADF
      REAL XS(STAVEC(1),STAVEC(3),STAVEC(4)) ! TABLE FOR XS
      REAL ADF(STAVEC(12),STAVEC(1),STAVEC(4))
      REAL SCAT(STAVEC(1)*STAVEC(1),STAVEC(4))
      REAL BURN(STAVEC(4)),XSC(4),DATSRC(5)
      REAL DIV(3,STAVEC(4))
      REAL ND(2,STAVEC(4))
      CHARACTER(len=4) BRANCH
      CHARACTER*12 FILNAM
      CHARACTER COM
      CHARACTER*16 JOBTIT
      CHARACTER*1 DER
      REAL VERS,SFAC,BFAC
      LOGICAL :: LTH = .FALSE.
      LOGICAL :: LADF = .FALSE.
      LOGICAL :: LXES = .FALSE.
      ! INITIALIZATION OF VARIABLES
      NGP=STAVEC(1)
      NVAR=STAVEC(2)
      NXS=STAVEC(3)
      NBU=STAVEC(4)
      GRID=STAVEC(5)
      NSF=STAVEC(11)
      NADF=STAVEC(13)
*
      IF(IPRINT > 0)  THEN
        WRITE(6,*)
        WRITE(6,*) "**** WRITING CURRENT BRANCH IN HELIOS FILE ****"
      ENDIF
      ! RECOVER INFORMATION FROM INFO DATA BLOCK
      CALL LCMSIX(IPDAT,' ',0)
      CALL LCMSIX(IPDAT,'SAPHYB_INFO',1)
      CALL LCMGET(IPDAT,'BURN',BURN)
      CALL LCMSIX(IPDAT,' ',0)
      CALL LCMSIX(IPDAT,'HELIOS_HEAD',1)
      CALL LCMGET(IPDAT,'XS_CONT',XSC)
      CALL LCMSIX(IPDAT,' ',0)
      CALL LCMSIX(IPDAT,'GENPMAXS_INP',1)
      CALL LCMGET(IPDAT,'DAT_SRC',DATSRC)
      CALL LCMGTC(IPDAT,'JOB_OPT',4,14,JOBOPT)
      CALL LCMSIX(IPDAT,' ',0)
      CALL LCMSIX(IPDAT,'BRANCH_INFO',1)
      CALL LCMGET(IPDAT,'PRINT',FLPRIN)
      CALL LCMGET(IPDAT,'STATE_INDEX',STAIDX)
      CALL LCMGET(IPDAT,'BRANCH_IT',ITBRAN)
      CALL LCMGTC(IPDAT,'BRANCH',4,1,BRANCH)

      IF(JOBOPT(1)=='T') LADF = .TRUE.
      IF(JOBOPT(2)=='T') LXES = .TRUE.
      IF((JOBOPT(5)=='T').OR.(JOBOPT(7)=='T').OR.
     > (JOBOPT(9)=='T').OR.(JOBOPT(13)=='T').OR.(JOBOPT(12)=='T'))THEN
        LTH =.TRUE.
      ENDIF

      ! WRITE THE CURRENT BRANCH IN THE HELIOS.DRA FILE
      IF(FLPRIN==1) THEN
         ! RECOVER CROSS SECTIONS FROM THE TEMPORARY FILE
         CALL READXS  (  IPDAT,     XS,   SCAT,    ND,     DIV,    NGP,
     >                     NXS,    ADF,    NBU,  NADF,   DATSRC,  GRID,
     >                    LADF,   LXES, IPRINT                        )

         ! WRITE IN HELIOS.DRA THE SET OF BURNUP POINTS
         CALL SETBU (IPHEL,BRANCH,ITBRAN,XSC,BURN,NBU,          IPRINT)

         ! WRITE IN HELIOS.DRA THE SET OF CROSS SECTIONS
         CALL SETXS   (  IPHEL, BRANCH, ITBRAN,    XS,     NGP,    NXS,
     >                     NBU,   BURN, DATSRC,    LXES,IPRINT        )

         ! WRITE IN HELIOS.DRA THE ELEMENT OF THE SCATTERING MATRIX
         CALL SETSCT(IPHEL,BRANCH,ITBRAN,SCAT,NGP,NBU,BURN,     IPRINT)

         IF(DATSRC(3)==1.0) THEN
           IF(LXES) THEN
            ! WRITE IN HELIOS.DRA THE NUMBRE DENSITIES FOR XENON AND
            ! SAMARIUM
            CALL SETND (IPHEL,BRANCH,ITBRAN,  ND,NBU,BURN,       IPRINT)
           ENDIF
           IF(GRID<2)THEN
            ! WRITE IN HELIOS.DRA THE DIVERS INFORMATION
            CALL SETDIV(IPHEL,BRANCH,ITBRAN,DIV,NBU,BURN,IPRINT)
           ENDIF
           IF(LTH) THEN
           ! WRITE IN HELIOS.DRA THE T:H INVARIANT DATA BLOCK
           CALL SETTH  (  IPHEL, BRANCH, ITBRAN,  BURN,     NBU, JOBOPT,
     >                      NGP,  IPDAT, IPRINT                        )
           ENDIF
           IF(LADF) THEN
            CALL SETADF(  IPHEL, BRANCH, ITBRAN,   ADF,    NADF,    NGP,
     >                      NBU,   BURN, IPRINT                        )
           ENDIF
         ENDIF
         ! SIGNATURE OF THE END OF A BRANCH (MANDATORY FOR GENPMAXS
         ! CODE)
         WRITE(IPHEL,*)
         WRITE(IPHEL,30)'*********************************************'
         WRITE(IPHEL,30)'* Normal End,    No warning messages issued *'
         WRITE(IPHEL,30)'*                                           *'
         WRITE(IPHEL,30)'*   Total CPU time used =                   *'
         WRITE(IPHEL,30)'*********************************************'
  30     FORMAT(25X,A)
      ENDIF

      ! UPDATE OF THE INFO DATA BLOCK
      CALL LCMSIX(IPDAT,' ',0)
      CALL LCMSIX(IPDAT,'GENPMAXS_INP',1)
      CALL LCMPUT(IPDAT,'FLAG',1,1,1)

      IF(IPRINT > 0)  THEN
        WRITE(6,*) "******** UPDATING the GENPMAXS.INP FILE *********"
      ENDIF
      ! UPDATE OF THE GENPMAXS.INP FILE (MANY ARGUMENTS IN THIS CALL
      ! ARE NOT USED IN D2PGEN)
      CALL      D2PGEN ( IPINP, IPDAT,   STAVEC, JOBTIT, FILNAM, DER,
     >                 VERS,   COM,   JOBOPT,   IUPS,   FA_K,   SFAC,
     >                 BFAC,   DEB,   IPRINT                        )
      IF(IPRINT > 0)  THEN
        WRITE(6,*)"********* SELECTING A NEW BRANCH CALCULATION *****"
      ENDIF

      CALL D2PSEL   (  IPDAT,  IPINP, STAVEC,BRANCH,  ITBRAN, STAIDX,
     >                  NVAR, JOBOPT,    DEB,IPRINT                 )

      WRITE(6,*) "*********       BRANCH SELECTED              *****"
      END

      SUBROUTINE SETBU(IPHEL,BRANCH,ITBRAN,XSC,BURN,NBU,IPRINT)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Write in the HELIOS.dra file the inforamtion about burnup points and
* XSC card (NUmber of burnup points (NBU), sides in assembly (NSIDES),
* corners in assembly (NCORNERS), VFCM).
* This routine write sequentially the HELIOS.dra file, branch after
* branch.
*
*parameters: input
* IPHEL      file unit of the HELIOS.dra file
* BRANCH     nature of the current branch ( CR, DC, CB, TC, TM etc )
* ITBRAN     index of the current branch
* XSC        content of the XS_CONT card
* BURN       set of burnup points
* NBU        number of bunup points
* IPRINT     control the printing on screen
*
*-----------------------------------------------------------------------
*
*----
*  SUBROUTINE ARGUMENTS
*----
      INTEGER NBU,ITBRAN,IPHEL,IPRINT
      REAL XSC(4),BURN (NBU)
      CHARACTER BRANCH*4
*----
*  LOCAL VARIABLES
*----
      ! number of sides and corners in assembly
      INTEGER NSIDE, NCORNER

      IF(IPRINT>5) WRITE(6,*) 'SETBU: WRITE BURNUP INFO'

      NSIDE = NINT(XSC(2))
      NCORNER = NINT(XSC(3))

      ! XS_CONT CARD (Cf DRAG2PARCS Manual for details on HELIOS format)

      ! HEADER OF XS_CONT card
      WRITE(IPHEL,'()')
      WRITE(IPHEL,*) 'List name       : PMAX_FILE_DATA'
      WRITE(IPHEL,*) 'Labels Array    : KINF'
      WRITE(IPHEL,*) 'List Title(s)  1) ==========================='
      WRITE(IPHEL,*) '               2) %STAT_xxxx'
      WRITE(IPHEL,*) '               3) ==========================='
      WRITE(IPHEL,*) '               4)%XS_CONT'
      WRITE(IPHEL,*) '               5)Meaning : NBN,NSIDE,NCORNER,'
     1 //'VFCM'

      ! RIEGO block of HELIOS.dra file
      CALL SET_RIEGO(IPHEL)

      ! Set the content of XS_CONT in HELIOS.dra
      WRITE(IPHEL,'(25X,4A14)') '           NBN',
     1   '         NSIDE','       NCORNER','          VFCM'
      WRITE(IPHEL,200) 'Label E','.-.-E-.-.','.-.-E-.-.','.-.-E-.-.',
     1     '1-.-E-.-.'
      WRITE(IPHEL,'(I4,1X,A,A,I4,A,A,I4,A,I5,3I14,3X,ES11.5E2)')
     1 1,'t',BRANCH(1:2),ITBRAN,'(s',BRANCH(1:2),ITBRAN,'):',
     2 0,NBU,NSIDE,NCORNER,
     3 XSC(4)
      WRITE(IPHEL,*) '<<< DRAGON >>> Version: 5.0.0 <<< DRAGON >>>'

      ! BURNUP INFORMATION

      ! HEADER OF Burnup card
      WRITE(IPHEL,'()')
      WRITE(IPHEL,*) 'List name       : PMAX_FILE_DATA'
      WRITE(IPHEL,*) 'Labels Array    : KINF'
      WRITE(IPHEL,*) 'List Title(s)  1) ==========================='
      WRITE(IPHEL,*) '               2) %XS_STAT'
      WRITE(IPHEL,*) '               3) ==========================='
      WRITE(IPHEL,*) '               4)Meaning : Bunrup'

      ! RIEGO block of HELIOS.dra file
      CALL SET_RIEGO(IPHEL)

      WRITE(IPHEL,'(30X,A6)') 'BURNUP'
      WRITE(IPHEL,210) 'Label E','.-.-E-.-.'
      ! LOOP over burnup points
      DO IT=1, NBU
          WRITE(IPHEL,220) IT,'t',BRANCH(1:2),ITBRAN,'(s',
     1    BRANCH(1:2),ITBRAN,'):',NINT(BURN(IT)),BURN(IT)/1000.0
      ENDDO
      WRITE(IPHEL,*) '<<< DRAGON >>> Version: 5.0.0 <<< DRAGON >>>'

      ! format of HELIOS.dra file
  200 FORMAT(6X,A,17X,A,5X,A,5X,A,5X,A)
  210 FORMAT(6X,A,17X,A)
  220 FORMAT(I4,1X,A,A,I3,A,A,I3,A,I5,8X,F6.3)
      END

      SUBROUTINE READXS (IPDAT,     XS,   SCAT,    ND,     DIV,    NGP,
     >                     NXS,    ADF,    NBU,   NSF,   DATSRC,  GRID,
     >                    LADF,   LXES, IPRINT                        )
*
*-----------------------------------------------------------------------
*
*Purpose:
* Recover cross section from the INFO data block.
*
*parameters: input
* IPDAT      address of info data block
* XS         table of cross sections
* SCAT       scattering matrix
* ND         number densities for xenon and samarium
* DIV        divers info directory
* NGP        number of energy groups
* NXS        number of cross sections
* NBU        number of burnup points
* ADF        assembly dicontinuity factor
* NSF        number of surfaces in assambly
* GRID       type of gridding for branching calculation
* LADF       flag for assembly discontinuity factors
* LXES       flag for microscopic cross sections
* DAT SRC    array containing the DATA source (reflector of fuel)
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPDAT
      INTEGER NGP,NBU, NXS,NSF,GRID
      REAL DATSRC(5)
      REAL XS(NGP,NXS,NBU)
      REAL SCAT(NGP*NGP,NBU)
      REAL ND(2,NBU)
      REAL DIV(3,NBU)
      REAL ADF(NSF,NGP,NBU)
      LOGICAL LADF,LXES
*----
*  LOCAL VARIABLES
*----
      TYPE(C_PTR) IPTH,KPTH
      INTEGER BU

      IF(IPRINT>5) WRITE(6,*) 'READXS: RECOVER INFO DATA BLOCK'

      ! LOOP over burnup points
      DO BU=1, NBU
         CALL LCMSIX(IPDAT,' ',0)
         CALL LCMSIX(IPDAT,'BRANCH_INFO',1)
         IPTH=LCMGID(IPDAT,'CROSS_SECT')
         KPTH=LCMDIL(IPTH,BU)
         CALL LCMSIX(KPTH,'MACROLIB_XS',1)
         CALL LCMGET(KPTH,'XTR',XS(1:NGP,1,BU))
         CALL LCMGET(KPTH,'ABSORPTION',XS(1:NGP,2,BU))
         CALL LCMGET(KPTH,'X_NU_FI',XS(1:NGP,3,BU))
         CALL LCMGET(KPTH,'KAPPA_FI',XS(1:NGP,4,BU))
         IF(LXES)CALL LCMGET(KPTH,'SFI',XS(1:NGP,7,BU))
         IF(LADF)CALL LCMGET(KPTH,'ADF',ADF(:,:,BU))
         CALL LCMGET(KPTH,'DET',XS(1:NGP,8,BU))
         CALL LCMGET(KPTH,'SCAT',SCAT(1:NGP*NGP,BU))
         IF(DATSRC(3)==1) THEN
          IF(LXES) THEN
            CALL LCMSIX(KPTH,' ',2)
            CALL LCMSIX(KPTH,'MICROLIB_XS',1)
            CALL LCMGET(KPTH,'XENG',XS(1:NGP,5,BU))
            CALL LCMGET(KPTH,'SMNG',XS(1:NGP,6,BU))
            CALL LCMGET(KPTH,'XEND',ND(1,BU))
            CALL LCMGET(KPTH,'SMND',ND(2,BU))
          ENDIF
          IF(GRID<2) THEN
            CALL LCMSIX(IPDAT,' ',0)
            CALL LCMSIX(IPDAT,'BRANCH_INFO',1)
            IPTH=LCMGID(IPDAT,'DIVERS')
            KPTH=LCMDIL(IPTH,BU)
            CALL LCMGET(KPTH,'KEFF',DIV(1,BU))
            CALL LCMGET(KPTH,'KINF',DIV(2,BU))
            CALL LCMGET(KPTH,'B2',DIV(3,BU))
          ENDIF
         ENDIF
      ENDDO
      END

      SUBROUTINE SETXS(  IPHEL, BRANCH, ITBRAN,    XS,     NGP,    NXS,
     >                     NBU,   BURN, DATSRC,    LXES, IPRINT       )
*
*-----------------------------------------------------------------------
*
*Purpose:
* Write in the HELIOS.dra file the cross sections for a banch
* (including all burnup points).
* This routine write sequentially the HELIOS.dra file, branch after
* branch.
*
*parameters: input
* IPHEL      file unit of the HELIOS.dra file
* BRANCH     nature of the current branch ( CR, DC, CB, TC, TM etc )
* ITBRAN     index of the current branch
* XS         table of cross sections
* NGP        number of energy groups
* NXS        number of cross sections
* NBU        number of burnup points
* ADF        assembly dicontinuity factor
* NSF        number of surfaces in assambly
* BURN       set of burnup points
* IPRINT     control the printing on screen
* DATSRC     array containing the DATA source (reflector of fuel)
* LXES       flag for presence of micoscopic cross sections
*
*-----------------------------------------------------------------------
*
*----
*  SUBROUTINE ARGUMENTS
*----
      INTEGER IPHEL,NBU,NXS,NGP,ITBRAN
      REAL XS(NGP,NXS,NBU),BURN (NBU),DATSRC(3)
      CHARACTER(len=4) BRANCH,XS_name
      LOGICAL LXES
*----
*  LOCAL VARIABLES
*----
      INTEGER XST  ! INDEX OF CROSS SECTIONS
      REAL FA_KIND
      LOGICAL :: LXS = .TRUE.

      IF(IPRINT>5) WRITE(6,*) 'SETXS: WRITE INFO FOR A BANCH'

      FA_KIND=DATSRC(3)

      ! LOOP OVER CROSS SECTIONS TYPE
      DO XST=1, NXS
         LXS = .TRUE.
         SELECT CASE (XST)
         CASE (1)
            XS_name = 'STR'               ! TRANSPORT XS
         CASE (2)
            XS_name = 'SAB'               ! ABSORPTION XS
         CASE (3)
            XS_name = 'SNF'               ! NU SIGMA FISSION XS
         CASE (4)
            XS_name = 'SKF'               ! KAPPA FISSION XS
         CASE (5)
            IF(.NOT. LXES) LXS=.FALSE.
            XS_name = 'XENG'              ! XE MICROSCOPIC ABSORPTION XS
         CASE (6)
            IF(.NOT. LXES) LXS=.FALSE.
            XS_name = 'SMNG'              ! SM MICROSCOPIC ABSORPTION XS
         CASE (7)
            IF(.NOT. LXES) LXS=.FALSE.
            XS_name = 'SFI'               ! FISSION XS
         CASE (8)
            XS_name = 'DET'               ! DETECTOR XS
         END SELECT
         IF(LXS) THEN
          ! LABEL FOR XS TYPE
          WRITE(IPHEL,'()')
          WRITE(IPHEL,*) 'List name       : PMAX_FILE_DATA'
          WRITE(IPHEL,*) 'Labels Array    : PrintVector'
          WRITE(IPHEL,110) XS_name
          WRITE(IPHEL,120) XS_name

  110     FORMAT(29H List Title(s)  1) %XS_PRIN %,A)
  120     FORMAT(34H Meaning : (.-.-E-G-.) G-th Group ,A,
     1    15H cross sections)

          CALL SET_RIEGO(IPHEL)

         ! LOOP OVER ENERGY GROUPS
         ! CREATION OF LABEL FOR CROSS SECTIONS
          DO IT=1, NGP
           IF(IT==1) THEN
            WRITE(IPHEL,'(30X,A4,A2)',advance='no') XS_name,'Xs'
           ELSE IF(IT==NGP .OR. IT==7 ) THEN
            WRITE(IPHEL,'(8X,A4,A2)')XS_name,'Xs'
           ELSE
            WRITE(IPHEL,'(8X,A4,A2)',advance='no')XS_name,'Xs'
           ENDIF
          ENDDO
          DO IT=1, NGP
           IF(IT==1) THEN
            WRITE(IPHEL,'(6X,A,17X,A,I1,A)',advance='no')
     1      'Label E','.-.-E-',IT,'-.'
           ELSE IF(IT==NGP .OR. IT==7 ) THEN
            WRITE(IPHEL,'(5X,A,I1,A)')
     1      '.-.-E-',IT,'-.'
           ENDIF
          ENDDO

          ! STORE XS DATA IN HELIOS.DRA FILE
          ! LOOP OVER BURNUP POINTS
          DO NB=1, NBU
            WRITE(IPHEL,220,advance='no') NB,'t',BRANCH(1:2),
     1      ITBRAN,'(s',BRANCH(1:2),ITBRAN,'):',NINT(BURN(NB))
            DO NG=1, NGP
              IF(NG == 1) THEN
               WRITE(IPHEL,'(3X,ES11.5E2)',advance='no') XS(NG,XST,NB)
              ELSE IF(NG.NE.NGP) THEN
               WRITE(IPHEL,'(3X,ES11.5E2)',advance='no') XS(NG,XST,NB)
              ELSE
                WRITE(IPHEL,'(3X,ES11.5E2)') XS(NG,XST,NB)
              ENDIF
            ENDDO ! NG
          ENDDO ! NB

  220     FORMAT(I4,1X,A,A,I4,A,A,I4,A,I5)
          WRITE(IPHEL,*) '<<< DRAGON >>> Version: 5.0.0 <<< DRAGON >>>'
         ENDIF
      ENDDO ! XST
      END

      SUBROUTINE SETADF(  IPHEL, BRANCH, ITBRAN,   ADF,    NADF,   NGP,
     >                      NBU,   BURN, IPRINT                       )
*
*-----------------------------------------------------------------------
*
*Purpose:
* Write in the HELIOS.dra file the cross sections for a banch
* (including all burnup points).
* This routine write sequentially the HELIOS.dra file, branch after
* branch.
*
*parameters: input
* IPHEL      file unit of the HELIOS.dra file
* BRANCH     nature of the current branch ( CR, DC, CB, TC, TM etc )
* ITBRAN     index of the current branch
* NGP        number of energy groups
* NBU        number of burnup points
* NADF       number of Assembly discontinuity factor
* ADF        Assembly discontinuity factor
* BURN       set of burnup points
*
*-----------------------------------------------------------------------
*
*----
*  SUBROUTINE ARGUMENTS
*----
      INTEGER IPHEL,NBU,NGP,NADF,ITBRAN,NIT,IPRINT
      REAL ADF(NADF,NGP,NBU),BURN (NBU)
      CHARACTER BRANCH*4
*----
*  LOCAL ARGUMENTS
*----
      INTEGER IT
      REAL ADF_TMP(NADF,NGP,NBU)

      IF(IPRINT>5) WRITE(6,*) 'SETADF: RECOVER ADF INFO'
      NIT=0
      IF((NADF.NE.1) .AND. (NADF.NE.4)) THEN
          WRITE(6,*) "NUMBER OF ADF : ",NADF
          CALL XABORT (" NUMBER OF ADF MUST BE 4 (SEL/GET) OR 1 (DRA)")
      ELSE IF(NADF == 4) THEN
         ! CASE FOR SEL OR GET ADF
         ! REARRANGEMENT OF ADF ORDER TO MATCH HELIOS iN CASE OD SEL OR
         ! GET ADF
         ! SAPHYB SURF => SIDE
         !        1        N
         !        2        E
         !        3        S
         !        4        W
         ! HELIOS SURF => SIDE
         !        1        W
         !        2        S
         !        3        E
         !        4        N

          ADF_TMP(:,:,:)=ADF(:,:,:)
          ADF(1,:,:)=ADF_TMP(4,:,:)
          ADF(2,:,:)=ADF_TMP(3,:,:)
          ADF(3,:,:)=ADF_TMP(2,:,:)
          ADF(4,:,:)=ADF_TMP(1,:,:)
          NIT =   NGP*NADF-1
      ELSE IF(NADF == 1) THEN
          NIT =   NGP
      ENDIF

      ! LOOP OVER CROSS SECTIONS TYPE
      ! LABEL FOR XS TYPE
      WRITE(IPHEL,'()')
      WRITE(IPHEL,*) 'List name       : PMAX_FILE_DATA'
      WRITE(IPHEL,*) 'Labels Array    : PrintVector'
      WRITE(IPHEL,*) 'List Title(s)  1) %XS_PRIN %SDF 2'
      WRITE(IPHEL,*)'2) Meaning : (F-.-E-G-.) F-Face, G-Group'
      IF(NADF==4) THEN
         WRITE(IPHEL,*)'3)          F=1/2/3/4 denotes W/S/E/N Side'
      ELSE
         WRITE(IPHEL,*)'3)          F=1 denotes average ADF'
      ENDIF

      CALL SET_RIEGO(IPHEL)

      !  LOOP OVER ENERGY GROUPS
      !  CREATION OF LABEL FOR CROSS SECTIONS
       DO IT=1,NIT
          IF(IT==1) THEN
            WRITE(IPHEL,'(33X,A6)',advance='no') 'SideDF'
          ELSE IF(IT==NIT) THEN
            WRITE(IPHEL,'(8X,A6)')'SideDF'
          ELSE
            WRITE(IPHEL,'(8X,A6)',advance='no')'SideDF'
          ENDIF
       ENDDO
       IT=0
       DO ngrp=1, NGP
         DO nsurf=1,NADF
            IT=IT+1
            IF(IT .LT. 8) THEN
             IF(ngrp==1 .and.nsurf==1) THEN
              WRITE(IPHEL,'(6X,A,17X,I1,A,I1,A)',advance='no')
     >        'Label E',nsurf,'-.-E-',ngrp,'-.'
             ELSEIF  (ngrp==2 .and.nsurf==3)  THEN
              WRITE(IPHEL,'(5X,I1,A,I1,A)')
     >        nsurf,'-.-E-',ngrp,'-.'
             ELSE
              IF(ngrp==2 .and. NADF==1) THEN
               WRITE(IPHEL,'(5X,I1,A,I1,A)') nsurf,'-.-E-',ngrp,'-.'
              ELSE
               WRITE(IPHEL,'(5X,I1,A,I1,A)',advance='no')
     >         nsurf,'-.-E-',ngrp,'-.'
              ENDIF
             ENDIF
            ENDIF
         ENDDO
      ENDDO

      ! STORE XS DATA IN HELIOS.DRA FILE
      ! LOOP OVER BURNUP POINTS
      DO NB=1,NBU
         WRITE(IPHEL,220,advance='no') NB,'t',BRANCH(1:2),
     >   ITBRAN,'(s',BRANCH(1:2),ITBRAN,'):',NINT(BURN(NB))
         IT=0
         DO NG=1,NGP
            DO NF=1,NADF
              IT=IT+1
              IF(IT .LT. 8) THEN
                IF(NG==2 .and.NF==3) THEN
                  WRITE(IPHEL,'(7X,F7.5)') ADF(NF,NG,NB)
                ELSEIF(NG==1 .and.NF==1) THEN
                  WRITE(IPHEL,'(5X,F7.5)',advance='no') ADF(NF,NG,NB)
                ELSE
                  IF(NG==2 .and. NADF ==1) THEN
                    WRITE(IPHEL,'(7X,F7.5)') ADF(NF,NG,NB)
                  ELSE
                    WRITE(IPHEL,'(7X,F7.5)',advance='no') ADF(NF,NG,NB)
                  ENDIF
                ENDIF
              ENDIF
            ENDDO
         ENDDO
      ENDDO

      WRITE(IPHEL,*)
      IF(NADF==4) THEN
         WRITE(IPHEL,'(33X,A6)') 'SideDF'
         WRITE(IPHEL,'(6X,A,17X,I1,A,I1,A)')
     >        'Label E',NADF,'-.-E-',NGP,'-.'
          DO NB=1, NBU
           WRITE(IPHEL,220,advance='no') NB,'t',BRANCH(1:2),
     >      ITBRAN,'(s',BRANCH(1:2),ITBRAN,'):',NINT(BURN(NB))
           WRITE(IPHEL,'(5X,F7.5)') ADF(NADF,NGP,NB)
          ENDDO
      ENDIF
  220 FORMAT(I4,1X,A,A,I4,A,A,I4,A,I5)

      WRITE(IPHEL,*) '<<< DRAGON >>> Version: 5.0.0 <<< DRAGON >>>'
      END

      SUBROUTINE SETSCT(IPHEL,BRANCH,ITBRAN,SCAT,NGP,NBU,BURN,IPRINT)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Write in the HELIOS.dra file the scattering cross sections for a banch
* (including all burnup points).
* This routine write sequentially the HELIOS.dra file, branch after
* branch.
*
*parameters: input
* IPHEL      file unit of the HELIOS.dra file
* BRANCH     nature of the current branch ( CR, DC, CB, TC, TM etc )
* ITBRAN     index of the current branch
* SCAT       table of elements of scattering matrix
* NGP        number of energy groups
* NBU        number of burnup points
* BURN       set of burnup points
*
*-----------------------------------------------------------------------
*
*----
*  SUBROUTINE ARGUMENTS
*----
      INTEGER IPHEL,NBU,NGP,ITBRAN,IPRINT
      REAL SCAT(NGP*NGP,NBU),BURN (NBU)
      CHARACTER BRANCH*2
*----
*  LOCAL ARGUMENTS
*----
      INTEGER IT

      IF(IPRINT>5) WRITE(6,*) 'SETSCT: WRITE SCATTERING INFO'

      ! LABEL FOR SCATTERING XS
      WRITE(IPHEL,'()')
      WRITE(IPHEL,*) 'List name       : PMAX_FILE_DATA'
      WRITE(IPHEL,*) 'Labels Array    : PrintVector'
      WRITE(IPHEL,110) '%SCT'
      WRITE(IPHEL,*)'Meaning : (.-.-E-G-O) From O to G-th Group scat'

      CALL SET_RIEGO(IPHEL)

      ! CREATION OF HEADER FOR SCATTERING BLOCK IN HELIOS.DRA FILE
      DO IT=1, NGP
        DO JT=1, NGP
         IF(IT==1 .and. JT==1) THEN
            WRITE(IPHEL,'(28X,A)',advance='no') 'ScattMatrix'
         ELSE IF((IT==(NGP).and.JT==(NGP)) .OR. JT==7 ) THEN
            WRITE(IPHEL,'(3X,A)')'ScattMatrix'
         ELSE
            WRITE(IPHEL,'(3X,A)',advance='no')'ScattMatrix'
         ENDIF
        ENDDO
      ENDDO

      DO IT=1, NGP
        DO JT=1, NGP
          IF(IT==1 .and. JT==1) THEN
            WRITE(IPHEL,'(6X,A,17X,A,I1,A,I1)',advance='no')
     1       'Label E','1-.-E-',JT,'-',IT
          ELSE IF((IT==(NGP).and.JT==(NGP)) .OR. JT==7 ) THEN
            WRITE(IPHEL,'(5X,A,I1,A,I1)')
     1       '1-.-E-',JT,'-',IT
          ELSE
            WRITE(IPHEL,'(5X,A,I1,A,I1)',advance='no')
     1       '1-.-E-',JT,'-',IT
          ENDIF
        ENDDO
      ENDDO

      DO NB=1, NBU
          WRITE(IPHEL,220,advance='no') NB,'t',BRANCH(1:2),
     1    ITBRAN,'(s',BRANCH(1:2),ITBRAN,'):',NINT(BURN(NB))
          DO IG=1, NGP*NGP
            IF(IG == 1) THEN
             WRITE(IPHEL,'(3X,ES11.5E2)',advance='no') SCAT(IG,NB)
            ELSE IF(IG.EQ.NGP*NGP) THEN
              WRITE(IPHEL,'(3X,ES11.5E2)') SCAT(IG,NB)
            ELSE IF(IG.EQ.7  ) THEN
             WRITE(IPHEL,'(3X,ES11.5E2)') SCAT(IG,NB)
            ELSE
             WRITE(IPHEL,'(3X,ES11.5E2)',advance='no') SCAT(IG,NB)
            ENDIF
          ENDDO
      ENDDO

  110 FORMAT(28H List Title(s)  1) %XS_SCT  ,A)
  220 FORMAT(I4,1X,A,A,I4,A,A,I4,A,I5)
      WRITE(IPHEL,*) '<<< DRAGON >>> Version: 5.0.0 <<< DRAGON >>>'
      END

      SUBROUTINE SETND(IPHEL,BRANCH,ITBRAN,ND,NBU,BURN,IPRINT)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Write in the HELIOS.dra file the scattering cross sections for a banch
* (including all burnup points).
* This routine write sequentially the HELIOS.dra file, branch after
* branch.
*
*parameters: input
* IPHEL      file unit of the HELIOS.dra file
* BRANCH     nature of the current branch ( CR, DC, CB, TC, TM etc )
* ITBRAN     index of the current branch
* NGP        number of energy groups
* NBU        number of burnup points
* ND         number densities for Xenon and samarium : KEFF , KINF, B2
* BURN       set of burnup points
*
*-----------------------------------------------------------------------
*
*----
*  SUBROUTINE ARGUMENTS
*----
      INTEGER IPHEL,NBU,ITBRAN,IPRINT
      REAL ND(2,NBU),BURN (NBU)
      CHARACTER BRANCH*2
*----
*  LOCAL ARGUMENTS
*----
      INTEGER NB

      IF(IPRINT>5) WRITE(6,*) 'SETND: WRITE HEADER FOR XENON DENSITY'

      ! CREATION OF HEADER FOR XENON DENSITY
      WRITE(IPHEL,'()')
      WRITE(IPHEL,*) 'List name       : PMAX_FILE_DATA'
      WRITE(IPHEL,*) 'Labels Array    : PrintVector'
      WRITE(IPHEL,*) 'List Title(s)  1) %XS_XESM %XEND'
      WRITE(IPHEL,*)'Meaning : Xe-135 Number Density [/cm.barn]'

      CALL SET_RIEGO(IPHEL)

      WRITE(IPHEL,'(33X,A)') 'nXe'
      WRITE(IPHEL,'(6X,A,17X,A)') 'Label E','1-1-E-.-.'

      ! LOOP OVER BUNRNUP
      DO NB=1,NBU
        WRITE(IPHEL,220,advance='no') NB,'t',BRANCH(1:2),
     1  ITBRAN,'(s',BRANCH(1:2),ITBRAN,'):',NINT(BURN(NB))
        WRITE(IPHEL,'(3X,ES11.5E2)') ND(1,NB)
      ENDDO

      WRITE(IPHEL,*) '<<< DRAGON >>> Version: 5.0.0 <<< DRAGON >>>'

      ! CREATION OF HEADER FOR SAMARIUM DENSITY
      WRITE(IPHEL,'()')
      WRITE(IPHEL,*) 'List name       : PMAX_FILE_DATA'
      WRITE(IPHEL,*) 'Labels Array    : PrintVector'
      WRITE(IPHEL,*) 'List Title(s)  1) %XS_XESM %SMND'
      WRITE(IPHEL,*)'Meaning : SM-149 Number Density [/cm.barn]'

      CALL SET_RIEGO(IPHEL)

      WRITE(IPHEL,'(33X,A)')  'nSm'
      WRITE(IPHEL,'(6X,A,17X,A)') 'Label E','1-1-E-.-.'

      ! LOOP OVER BUNRNUP
      DO NB=1,NBU
         WRITE(IPHEL,220,advance='no') NB,'t',BRANCH(1:2),
     1   ITBRAN,'(s',BRANCH(1:2),ITBRAN,'):',NINT(BURN(NB))
         WRITE(IPHEL,'(3X,ES11.5E2)') ND(2,NB)
      ENDDO
      WRITE(IPHEL,*) '<<< DRAGON >>> Version: 5.0.0 <<< DRAGON >>>'

  220 FORMAT(I4,1X,A,A,I4,A,A,I4,A,I5)
      END

      SUBROUTINE SETDIV(IPHEL,BRANCH,ITBRAN,DIV,NBU,BURN,IPRINT)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Write in the HELIOS.dra file the scattering cross sections for a banch
*  (including all burnup points).
* This routine write sequentially the HELIOS.dra file, branch after
* branch.
*
*parameters: input
* IPHEL      file unit of the HELIOS.dra file
* BRANCH     nature of the current branch ( CR, DC, CB, TC, TM etc )
* ITBRAN     index of the current branch
* NGP     number of energy groups
* NBU        number of burnup points
* DIV        conttnent of DIV table : KEFF , KINF, B2
* BURN       set of burnup points
*
*-----------------------------------------------------------------------
*
*----
*  SUBROUTINE ARGUMENTS
*----
      INTEGER IPHEL,NBU,ITBRAN,IPRINT
      REAL DIV(3,NBU),BURN (NBU)
      CHARACTER BRANCH*2
*----
*  LOCAL ARGUMENTS
*----
      INTEGER NB
      REAL M2

      IF(IPRINT>5) WRITE(6,*) 'SETDIV: WRITE HEADER FOR DIVERS INFO'

      ! CREATION OF HEADER FOR DIVERS INFO (B2, KEFF, KINF)
      WRITE(IPHEL,'()')
      WRITE(IPHEL,*) 'List name       : PMAX_FILE_DATA'
      WRITE(IPHEL,*) 'Labels Array    : KINF'
      WRITE(IPHEL,*) 'List Title(s)  1) %XS_PRIN %KINF'
      WRITE(IPHEL,*)' Meaning : K-eff, K-inf, M^2, B^2 [cm^-2]  '

      CALL SET_RIEGO(IPHEL)

      WRITE(IPHEL,'(32X,A,10X,A,6X,A,6X,A)') 'K-EFF','KINF',
     1  'MigrArea','CritArea'
      WRITE(IPHEL,'(6X,A,17X,A,5X,A,5X,A,5X,A)')
     1       'Label E','.-.-E-.-.','.-.-E-.-.','.-.-E-.-.','.-.-E-.-.'
      ! LOOP OVER BURNUP POINTS
      DO NB=1,NBU
         M2=(DIV(2,NB)-1)/(DIV(3,NB))
         WRITE(IPHEL,220,advance='no') NB,'t',BRANCH(1:2),
     1    ITBRAN,'(s',BRANCH(1:2),ITBRAN,'):',NINT(BURN(NB))
         WRITE(IPHEL,'(7X,F7.5,7X,F7.5,2X,ES12.5E2,2X,ES12.5E2)')
     1    DIV(1,NB),DIV(1,NB),M2,DIV(3,NB)
      ENDDO
      WRITE(IPHEL,*) '<<< DRAGON >>> Version: 5.0.0 <<< DRAGON >>>'

  220  FORMAT(I4,1X,A,A,I4,A,A,I4,A,I5)
       END

       SUBROUTINE SETTH(  IPHEL, BRANCH, ITBRAN,  BURN,     NBU, JOBOPT,
     >                      NGP,  IPDAT, IPRINT                        )
*
*-----------------------------------------------------------------------
*
*Purpose:
* Write in the HELIOS.dra file the invaraint TH DATA for a banch
* (including all burnup points).
* This routine write sequentially the HELIOS.dra file, branch after
* branch. 
*
*-----------------------------------------------------------------------
*
      USE GANLIB
      TYPE(C_PTR) IPDAT,IPTH,KPTH
      INTEGER :: DIM_LAMBDA = 6
      INTEGER NGP,ILONG
      INTEGER ITYLCM,NBU,ITBRAN
      CHARACTER (len=4) JOBOPT(14),BRANCH,DLAY
      INTEGER :: BU = 1
      REAL BURN(NBU)
      REAL YLDXe(NBU),YLDPm(NBU),YLDI(NBU)
      REAL OVERV(NGP,NBU),CHI(NGP,NBU),LAMBDA(6,NBU),BETA(6,NBU)
      LOGICAL :: LAMB = .FALSE.
      LOGICAL :: LCHI = .FALSE.
      LOGICAL :: LYLD = .FALSE.
      LOGICAL :: LINV = .FALSE.
      LOGICAL :: LBET = .FALSE.

      IF(IPRINT>5) WRITE(6,*) 'SETTH: WRITE TH DATA'

      ! RECOVER FLAG INFORMATION
      IF(JOBOPT(5)=='T') LCHI = .TRUE.
      IF(JOBOPT(7)=='T') LINV = .TRUE.
      IF(JOBOPT(9)=='T') LYLD = .TRUE.
      IF(JOBOPT(13)=='T') LAMB = .TRUE.
      IF(JOBOPT(12)=='T') LBET = .TRUE.

      IF(NGP>2)THEN
        CALL XABORT('@D2P: NGP > 2 NOT IMPLEMENTED FOR T/H BLOCK')
      ENDIF

      CALL LCMSIX(IPDAT,' ',0)
      IPTH=LCMGID(IPDAT,'TH_DATA')

      DO BU=1,NBU
         KPTH=LCMDIL(IPTH,BU)

         IF(LCHI) THEN
          IF(BU ==1) THEN
           CALL LCMLEN(KPTH,'CHI',ILONG,ITYLCM)
           IF  (ILONG .NE. NGP) THEN
            CALL XABORT (' MORE THAN 2 (NGP) VALUES FOR CHI RECORD')
           ENDIF
          ENDIF
          CALL LCMGET(KPTH,'CHI',CHI(1:NGP,BU))

         ENDIF

         IF(LINV) THEN
          CALL LCMGET(KPTH,'OVERV',OVERV(1:NGP,BU))

         ENDIF

         IF(LYLD) THEN
          CALL LCMGET(KPTH,'YLDPm',YLDPm(BU))
          CALL LCMGET(KPTH,'YLDXe',YLDXe(BU))
          CALL LCMGET(KPTH,'YLDI',YLDI(BU))

         ENDIF

         IF(LAMB)THEN
          IF(BU == 1) THEN
           CALL LCMLEN(KPTH,'LAMBDA',ILONG,ITYLCM)
           IF  (ILONG .NE. DIM_LAMBDA) THEN
            CALL XABORT('MORE THAN 6 (NDLAY) VALUES FOR LAMBDA RECORD')
           ENDIF
          ENDIF
          CALL LCMGET(KPTH,'LAMBDA',LAMBDA(1:DIM_LAMBDA,BU))
         ENDIF

         IF(LBET)THEN
          IF(BU == 1) THEN
           CALL LCMLEN(KPTH,'BETA',ILONG,ITYLCM)
           IF  (ILONG .NE. DIM_LAMBDA) THEN
            CALL XABORT('MORE THAN 6 (NDLAY) VALUES FOR BETA RECORD')
           ENDIF
          ENDIF
          CALL LCMGET(KPTH,'BETA',BETA(1:DIM_LAMBDA,BU))
         ENDIF
      ENDDO

      IF(LCHI) CALL SET_CHI(IPHEL,BRANCH,ITBRAN,BURN,CHI,NGP,NBU)
      IF(LINV) CALL SET_OVERV(IPHEL,BRANCH,ITBRAN,BURN,OVERV,NGP,NBU)
      IF(LYLD) CALL SET_YIELD(IPHEL,BRANCH,ITBRAN,BURN,YLDPm,YLDXe,
     >  YLDI,NBU)
      IF(LAMB) THEN
        DLAY='LAMB'
        CALL SET_DLAY(IPHEL,BRANCH,ITBRAN,BURN,LAMBDA,DIM_LAMBDA,DLAY,
     >  NBU)
      ENDIF
      IF(LBET) THEN
        DLAY='BETA'
        CALL SET_DLAY(IPHEL,BRANCH,ITBRAN,BURN,BETA,DIM_LAMBDA,DLAY,NBU)
      ENDIF
      END

      SUBROUTINE SET_CHI(IPHEL,BRANCH,ITBRAN,BURN,CHI,DIM_CHI,NBU)
      INTEGER DIM_CHI,NBU,ITBRAN,NB
      REAL CHI(DIM_CHI,NBU),BURN(NBU)
      CHARACTER (len=4) BRANCH

      WRITE(IPHEL,'()')
      WRITE(IPHEL,*) 'List name       : PMAX_FILE_DATA'
      WRITE(IPHEL,*) 'Labels Array    : PrintVector'
      WRITE(IPHEL,*) 'List Title(s)  1) %XS_PRIN %CHI'
      WRITE(IPHEL,*) 'Meaning :(.-.-E-G-.) G-th Group Fission Spect'

      CALL SET_RIEGO(IPHEL)

      WRITE(IPHEL,'(36X,A3,11X,A3)') 'chi','chi'
      WRITE(IPHEL,'(6X,A,17X,A,5X,A)') 'Label E','1-.-E-1-.','1-.-E-2-.'
      ! LOOP OVER burnup points
      DO NB=1,NBU
         WRITE(IPHEL,220,advance='no') NB,'t',BRANCH(1:2),
     1   ITBRAN,'(s',BRANCH(1:2),ITBRAN,'):',NINT(BURN(NB))
         WRITE(IPHEL,'(3X,ES11.5E2,2X,ES12.5E2)')
     1   CHI(1:DIM_CHI,NB)
      ENDDO
      WRITE(IPHEL,*) '<<< DRAGON >>> Version: 5.0.0 <<< DRAGON >>>'
  220 FORMAT(I4,1X,A,A,I4,A,A,I4,A,I5)
      END

      SUBROUTINE SET_OVERV(IPHEL,BRANCH,ITBRAN,BURN,OVERV,NG,NBU)
      INTEGER NG,NBU,ITBRAN,NB
      REAL OVERV(NG,NBU),BURN(NBU)
      CHARACTER (len=4) BRANCH

      WRITE(IPHEL,'()')
      WRITE(IPHEL,*) 'List name       : PMAX_FILE_DATA'
      WRITE(IPHEL,*) 'Labels Array    : PrintVector'
      WRITE(IPHEL,*) 'List Title(s)  1) %XS_PRIN %VEL'
      WRITE(IPHEL,*) 'Meaning         :'
      WRITE(IPHEL,*) '(.-.-E-G-.) G-th Group Neutron Velocity [m/s]'

      CALL SET_RIEGO(IPHEL)

      WRITE(IPHEL,'(36X,A3,11X,A3)') 'vel','vel'
      WRITE(IPHEL,'(6X,A,17X,A,5X,A)') 'Label E','.-.-E-1-.','.-.-E-2-.'
      ! LOOP OVER burnup points
      DO NB=1,NBU

         WRITE(IPHEL,220,advance='no') NB,'t',BRANCH(1:2),
     1   ITBRAN,'(s',BRANCH(1:2),ITBRAN,'):',NINT(BURN(NB))
         WRITE(IPHEL,'(3X,ES11.5E2,2X,ES12.5E2)')
     1   (1/(OVERV(1:NG,NB)))
      ENDDO
      WRITE(IPHEL,*) '<<< DRAGON >>> Version: 5.0.0 <<< DRAGON >>>'
  220 FORMAT(I4,1X,A,A,I4,A,A,I4,A,I5)
      END

      SUBROUTINE SET_YIELD(IPHEL,BRANCH,ITBRAN,BURN,YLDPm,YLDXe,YLDI,
     1 NBU)
      INTEGER NBU,ITBRAN,NB,I,iXe,iPm,iI
      REAL YLDPm(NBU), YLDXe(NBU),YLDI(NBU),BURN(NBU)
      REAL YLD(NBU)
      CHARACTER (len=4) BRANCH
      CHARACTER (len=5) YIELD
      CHARACTER (len=6) MEANING
      CHARACTER (len=10 ) LABEL

      DO I=1, 3
         SELECT CASE (I)
         CASE(1)
           YIELD='YLDXE'
           MEANING='Xe-135'
           LABEL='YieldXe135'
           DO iXe=1,NBU
            YLD(iXe)=YLDXe(iXe)
           ENDDO
         CASE(2)
           YIELD='YLDID'
           MEANING=' I-135'
           LABEL=' YieldI135'
           DO iI=1,NBU
            YLD(iI)=YLDI(iI)
           ENDDO
         CASE(3)
           YIELD='YLDPM'
           MEANING='Pr-149'
           LABEL='YieldPm149'
           DO iPm=1,NBU
            YLD(iPm)=YLDPm(iPm)
           ENDDO
         END SELECT

         WRITE(IPHEL,'()')
         WRITE(IPHEL,*) 'List name       : PMAX_FILE_DATA'
         WRITE(IPHEL,*) 'Labels Array    : PrintVector'
         WRITE(IPHEL,*) 'List Title(s)  1) %XS_XESM %',YIELD
         WRITE(IPHEL,*) 'Meaning : Effective ,',MEANING,' Yield'

         CALL SET_RIEGO(IPHEL)

         WRITE(IPHEL,'(29X,A10)') LABEL
         WRITE(IPHEL,'(6X,A,17X,A)') 'Label E','1-.-E-1-.'
          ! LOOP OVER burnup points
         DO NB=1,NBU

           WRITE(IPHEL,220,advance='no') NB,'t',BRANCH(1:2),
     1      ITBRAN,'(s',BRANCH(1:2),ITBRAN,'):',NINT(BURN(NB))
           WRITE(IPHEL,'(3X,ES11.5E2)') YLD(NB)
         ENDDO
         WRITE(IPHEL,*) '<<< DRAGON >>> Version: 5.0.0 <<< DRAGON >>>'
  220    FORMAT(I4,1X,A,A,I4,A,A,I4,A,I5)
      ENDDO
      END

      SUBROUTINE SET_DLAY(IPHEL,BRANCH,ITBRAN,BURN,VECT,DIM_LAMBDA,
     1 DLAY,NBU)
      INTEGER DIM_LAMBDA,NBU,ITBRAN,NB
      REAL VECT(DIM_LAMBDA,NBU),BURN(NBU)
      CHARACTER (len=4) BRANCH,DLAY
      CHARACTER (len=6) LABEL

      IF(DLAY.EQ.'LAMB') THEN
         LABEL="lambda"
      ELSE
         LABEL="beta  "
      ENDIF
      IF(DIM_LAMBDA.GT.8) THEN
         WRITE (6,*) "@D2PBRA: NB OF DELAY NEUTRON GROUPS:",DIM_LAMBDA
         CALL XABORT("MAX EIGHT DELAY NEUTRON GROUPS ARE ALLOWED")
      ENDIF
      WRITE(IPHEL,'()')
      WRITE(IPHEL,*) 'List name       : PMAX_FILE_DATA'
      WRITE(IPHEL,*) 'Labels Array    : PrintVector'
      IF(LABEL=="lambda")THEN
         WRITE(IPHEL,*) 'List Title(s)  1) %XS_BETA %DCAYB 1'
         WRITE(IPHEL,*) 'Meaning : Decay Cst of the Delayed Neutron /s'
      ELSE
         WRITE(IPHEL,*) 'List Title(s)  1) %XS_BETA %BETA 1  '
         WRITE(IPHEL,*) 'Meaning : Delayed Neutron Fraction'
      ENDIF
      WRITE(IPHEL,*) '          (.-.-E-G-.) From 0 To 6-th Group'

      CALL SET_RIEGO(IPHEL)
      IF(DIM_LAMBDA.EQ.6) THEN
          WRITE(IPHEL,'(33X,A6,8X,A6,8X,A6,8X,A6,8X,A6,8X,A6)')
     >      LABEL,LABEL,LABEL,LABEL,LABEL,LABEL
          WRITE(IPHEL,200)
     >      'Label E','.-.-E-1-.','.-.-E-2-.','.-.-E-3-.','.-.-E-4-.',
     >      '.-.-E-5-.','.-.-E-6-.'
         ! LOOP OVER burnup points
          DO NB=1,NBU
           WRITE(IPHEL,220,advance='no') NB,'t',BRANCH(1:2),
     >      ITBRAN,'(s',BRANCH(1:2),ITBRAN,'):',NINT(BURN(NB))
           WRITE(IPHEL,'(3X,ES11.5E2,5(3X,ES11.5E2))')
     >      VECT(1:DIM_LAMBDA,NB)
          ENDDO
      ELSE IF(DIM_LAMBDA.EQ.8) THEN
         WRITE(IPHEL,'(33X,A6,8X,A6,8X,A6,8X,A6,8X,A6,8X,A6,8X,A6)')
     >   LABEL,LABEL,LABEL,LABEL,LABEL,LABEL,LABEL
         WRITE(IPHEL,210)
     >     'Label E','.-.-E-1-.','.-.-E-2-.','.-.-E-3-.','.-.-E-4-.',
     >     '.-.-E-5-.','.-.-E-6-.','.-.-E-7-.'
         ! LOOP OVER burnup points
         DO NB=1,NBU
           WRITE(IPHEL,220,advance='no') NB,'t',BRANCH(1:2),
     >      ITBRAN,'(s',BRANCH(1:2),ITBRAN,'):',NINT(BURN(NB))
           WRITE(IPHEL,'(3X,ES11.5E2,6(3X,ES11.5E2))') VECT(1:7,NB)
         ENDDO

         WRITE(IPHEL,*)

         WRITE(IPHEL,'(33X,A6)') 'lambda'
         WRITE(IPHEL,'(6X,A,17X,A)') 'Label E',LABEL
         DO NB=1, NBU
            WRITE(IPHEL,220,advance='no') NB,'t',BRANCH(1:2),
     >      ITBRAN,'(s',BRANCH(1:2),ITBRAN,'):',NINT(BURN(NB))
            WRITE(IPHEL,'(3X,ES11.5E2)') VECT(DIM_LAMBDA,NB)
         ENDDO
      ENDIF
      WRITE(IPHEL,*) '<<< DRAGON >>> Version: 5.0.0 <<< DRAGON >>>'
  200 FORMAT(6X,A,17X,A,5X,A,5X,A,5X,A,5X,A,5X,A)
  210 FORMAT(6X,A,17X,A,5X,A,5X,A,5X,A,5X,A,5X,A,5X,A)
  220 FORMAT(I4,1X,A,A,I4,A,A,I4,A,I5)
      END
