Resolve "Depreciate use of Version 4 and 5.0 Draglibs"

1 files changed, 64 insertions, 9 deletions

diff --git a/Dragon/src/LIBXS4.f b/Dragon/src/LIBXS4.f
index 6debb37..459809d 100644
--- a/Dragon/src/LIBXS4.f
+++ b/Dragon/src/LIBXS4.f
@@ -68,20 +68,20 @@
       CHARACTER TEXT20*20,TEXT80*80,HNAMIS*12,HNISOR*12,HNISSS*12,
      1 HSMG*131,TEXT2*2,TEXT12*12
       LOGICAL LTRAN,LGPROB,LGTDIF,LGTTRA,LN2N,L104,LABS,LDIF,
-     1 LFIS,LPWD,LPED
+     1 LFIS,LPWD,LPED,LH
       INTEGER ZFISS,FGTD,FGHOMO,FGRESO,FAGG,FDGG,WGAL,FAG
       DOUBLE PRECISION UU,XDRCST
       INTEGER ITHOMO(MAXHOM),ITEXT(20)
-      REAL TKT(5)
+      REAL TKT(5),E458(9)
 *----
 *  ALLOCATABLE ARRAYS
 *----
       INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO,NFS,NOM,NOMS,ISECTT,
-     1 IFDG,IIAD,IDEPL
+     1 IFDG,IIAD,IDEPL,IPR2
       INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR
       REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,DELTA,SECT,XSTOT,TAUX,
      1 DELTF,SIGTF,SIGAF,SIGFF,ENER,AMASS,TEMP,TEMPS,SEQHO,PWD,PED,DKA,
-     2 DKD,DKF,DK104
+     2 DKD,DKF,DK104,HFACT
       REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS,CHID
       REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT
       LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGTRE
@@ -89,7 +89,7 @@
 *----
 *  SCRATCH STORAGE ALLOCATION
 *----
-      ALLOCATE(IPR(2,NBISO),ITYPRO(NL),NFS(NGRO))
+      ALLOCATE(IPR(2,NBISO),IPR2(NBISO),ITYPRO(NL),NFS(NGRO))
       ALLOCATE(ENERG(NGRO+1),DELTA(NGRO),SECT(NGRO),SIGS(NGRO,NL),
      1 SCAT(NGRO,NGRO,NL),XSTOT(NGRO))
 *
@@ -180,6 +180,7 @@
          WRITE (HSMG,780) HNISOR,NAMFIL
          CALL XABORT(HSMG)
    20    IPR(1,IMX)=KISO
+         IPR2(IMX)=KISO
 *
          IF((NISOTS.GT.0).AND.(HNISSS.NE.' ')) THEN
            KISO=0
@@ -199,8 +200,8 @@
          ENDIF
       ENDIF
    50 CONTINUE
-      DEALLOCATE(NOM)
       IF(NISOTS.GT.0) DEALLOCATE(NOMS)
+      DEALLOCATE(NOM)
       CALL KDRCPU(TK2)
       TKT(1)=TK2-TK1
 *----
@@ -877,7 +878,6 @@
       ENDIF
       CALL LCMSIX(IPAP,' ',2) ! QFIXS
   560 CONTINUE
-      CALL LCMCL(IPAP,1)
 *----
 *  CHECK IF ALL REACTIONS HAVE BEEN PROCESSED.
 *----
@@ -891,11 +891,15 @@
   575 CONTINUE
       IF(IMPX.GT.2) WRITE(IOUT,940) (TKT(I),I=1,5)
 *----
-*  ADD NG CROSS SECTIONS.
+*  LOOP OVER ISOTOPES
 *----
+      CALL LCMSIX(IPAP,'QFIX',1)
       DO 610 IMX=1,NBISO
       IF(MASKI(IMX)) THEN
          KPLIB=IPISO(IMX) ! set IMX-th isotope
+*----
+*  PROCESS NG INFORMATION
+*----
          CALL LCMGET(KPLIB,'NTOT0',SECT)
          CALL LCMLEN(KPLIB,'SIGS00',LENGT,ITYLCM)
          IF(LENGT.EQ.NGRO) THEN
@@ -919,14 +923,65 @@
   600       CONTINUE
          ENDIF
          CALL LCMPUT(KPLIB,'NG',NGRO,2,SECT)
+*----
+*  PROCESS H-FACTOR INFORMATION
+*----
+         CALL LCMLEN(KPLIB,'H-FACTOR',LENGT,ITYLCM)
+         IF(LENGT.NE.0) CALL LCMDEL(KPLIB,'H-FACTOR')
+         ISO=IPR2(IMX)
+         IF(ISO.EQ.0) CYCLE
+         WRITE(TEXT12,'(4HISOT,I8.8)') ISO
+         CALL LCMSIX(IPAP,TEXT12,1)
+         CALL LCMSIX(IPAP,'ISOTOP',1)
+         LH=.FALSE.
+         VALUE=0.0
+         ALLOCATE(HFACT(NGRO))
+         HFACT(:NGRO)=0.0
+*        NG ENERGY.
+         CALL LCMLEN(IPAP,'EGAMM',NV,ITYLCM)
+         IF(NV.NE.0) THEN
+            CALL LCMGET(IPAP,'EGAMM',VALUE)
+            IF(VALUE.NE.0.0) THEN
+              CALL LCMGET(KPLIB,'NG',SECT)
+              HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6
+              LH=.TRUE.
+            ENDIF
+         ENDIF
+*        FISSION ENERGIES.
+         CALL LCMLEN(IPAP,'EF',NV,ITYLCM)
+         IF(NV.NE.0) THEN
+            CALL LCMGET(IPAP,'EF',VALUE)
+            IF(VALUE.NE.0.0) THEN
+              CALL LCMGET(KPLIB,'NFTOT',SECT)
+              HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6
+              LH=.TRUE.
+              GO TO 605
+            ENDIF
+         ENDIF
+         CALL LCMLEN(IPAP,'ENER_458',NV,ITYLCM)
+         IF(NV.NE.0) THEN
+            CALL LCMGET(IPAP,'ENER_458',E458)
+            VALUE=E458(8)
+            IF(VALUE.NE.0.0) THEN
+              CALL LCMGET(KPLIB,'NFTOT',SECT)
+              HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6
+              LH=.TRUE.
+            ENDIF
+         ENDIF
+  605    IF(LH) CALL LCMPUT(KPLIB,'H-FACTOR',NGRO,2,HFACT)
+         DEALLOCATE(HFACT)
+         CALL LCMSIX(IPAP,' ',2) ! ISOTOP
+         CALL LCMSIX(IPAP,' ',2) ! TEXT12
       ENDIF
   610 CONTINUE
+      CALL LCMSIX(IPAP,' ',2) ! QFIX
+      CALL LCMCL(IPAP,1)
 *----
 *  SCRATCH STORAGE DEALLOCATION
 *----
       DEALLOCATE(AMASS)
       DEALLOCATE(XSTOT,SCAT,SIGS,SECT,DELTA,ENERG)
-      DEALLOCATE(NFS,ITYPRO,IPR)
+      DEALLOCATE(NFS,ITYPRO,IPR2,IPR)
       RETURN
 *
   780 FORMAT(26HLIBXS4: MATERIAL/ISOTOPE ',A12,20H' IS MISSING ON APOL,