Resolve "Depreciate use of Version 4 and 5.0 Draglibs"

1 files changed, 254 insertions, 0 deletions

diff --git a/Dragon/src/LIBEAQ.f b/Dragon/src/LIBEAQ.f
new file mode 100644
index 0000000..b969108
--- /dev/null
+++ b/Dragon/src/LIBEAQ.f
@@ -0,0 +1,254 @@
+*DECK LIBEAQ
+      SUBROUTINE LIBEAQ(CFILNA,NEL,IMPX,QQNG,QQF)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Recover Q and pseudo-Q values from an APOLIB2 file.
+*
+*Copyright:
+* Copyright (C) 2025 Ecole Polytechnique de Montreal
+* This library is free software; you can redistribute it and/or
+* modify it under the terms of the GNU Lesser General Public
+* License as published by the Free Software Foundation; either
+* version 2.1 of the License, or (at your option) any later version.
+*
+*Author(s): A. Hebert
+*
+*Parameters: input
+* CFILNA  APOLIB-2 file name.
+* NEL     number of isotopes on library.
+* IMPX    print flag.
+*
+*Parameters: output
+* QQNG    radiative capture Q value.
+* QQF     fission pseudo Q value.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      CHARACTER CFILNA*(*)
+      INTEGER NEL,IMPX
+      REAL QQNG(NEL),QQF(NEL)
+*----
+*  LOCAL VARIABLES
+*----
+      EXTERNAL LIBA21
+      INTEGER ISFICH(3),NITCA(5)
+      PARAMETER (IOUT=6)
+      CHARACTER TEXT20*20,NOMOBJ*20,TEXT12*12,TEXT16*16,TYPOBJ*8,
+     > TYPSEG*8,HNISOR*20,HSMG*131
+      LOGICAL LPHEAD,LPCONS,LPFIX
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: VINTE,NOMOB,KDS,LGS,ITCARO,
+     1 NOM
+      TYPE(C_PTR) ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR,TSEGM_PTR
+      INTEGER, POINTER, DIMENSION(:) :: ICHDIM,ICHTYP,ICHDKL,ITSEGM
+      REAL, POINTER, DIMENSION(:) :: RTSEGM
+*
+      INTEGER TKCARO(31)
+      SAVE TKCARO
+      DATA TKCARO /
+     &   0,   1,   2,   3,  4,   5,  6,  30,   7,  -8,
+     &   9, -10,  11, -12, 13, -14, 15,  16, -17,  18,
+     & -19,  20, -21,  22, 23, -24, 25, -26,  27, -28,
+     &  29   /
+*----
+*  OPEN AND PROBE THE APOLIB-2 FILE.
+*----
+      CALL AEXTPA(CFILNA,ISFICH)
+      IADRES=ISFICH(1)
+      NBOBJ=ISFICH(2)
+      LBLOC=ISFICH(3)
+      IUNIT=KDROPN(CFILNA,2,4,LBLOC)
+      IF(IUNIT.LE.0) THEN
+         TEXT12=CFILNA
+         CALL XABORT('LIBEAQ: APOLLO-2 LIBRARY '//TEXT12//' CANNOT B'//
+     1   'E OPENED')
+      ENDIF
+*----
+*  INDEX THE APOLIB-2 FILE.
+*----
+      ALLOCATE(VINTE(2*NBOBJ))
+      CALL AEXDIR(IUNIT,LBLOC,VINTE,IADRES,2*NBOBJ)
+      IDKNO=1-TKCARO(14)
+      IDKTY=1-TKCARO(21)
+      IDKDS=1-TKCARO(10)
+      IDKTS=1-TKCARO(23)
+      IDKNS=TKCARO(2)+1
+      IDKLS=TKCARO(8)
+*
+      NSEGM=0
+      NMGY=0
+      NISOT=0
+      ALLOCATE(NOMOB(5*(NBOBJ-3)),KDS(NBOBJ-3),LGS(NBOBJ-3))
+      LPHEAD=.FALSE.
+      LPCONS=.FALSE.
+      DO 80 IOBJ=3,NBOBJ
+      IDKOBJ=VINTE(2*IOBJ-1)
+      LGSEG=VINTE(2*IOBJ)+1
+      ALLOCATE(ITCARO(LGSEG))
+      CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG)
+      IDK=ITCARO(IDKNO)
+      CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ)
+      IDK=ITCARO(IDKTY)
+      CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ)
+      JDKDS=ITCARO(IDKDS)
+      JDKTS=ITCARO(IDKTS)
+      NS=ITCARO(IDKNS)
+      IF(TYPOBJ.EQ.'APOLIB') THEN
+         DO 70 IS=1,NS
+         IDK=JDKTS+8*(IS-1)
+         CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG)
+         LTESTS=ITCARO(IDKLS+IS)
+         IF(LTESTS.LE.0) GO TO 70
+         JDKS=ITCARO(JDKDS+IS)
+         CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,
+     1   ICHDKL_PTR)
+         CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /))
+         CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /))
+         CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /))
+         TSEGM_PTR=LCMARA(LTESTS+1)
+         CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LTESTS+1 /))
+         CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LTESTS+1 /))
+         CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LTESTS+1)
+         IF(TYPSEG.EQ.'PHEAD') THEN
+            LPHEAD=.TRUE.
+            CALL AEXGNV(3,ITSEGM,ICHDIM,ICHTYP,
+     1      ICHDKL,IDK,NV)
+            IF(NV.EQ.0) THEN
+               TEXT12=CFILNA
+               CALL XABORT('LIBEAQ: NO ISOTOPES PRESENT ON APOLIB-2 '//
+     1         'FILE NAMED: '//TEXT12)
+            ENDIF
+            NISOT=NV/20
+            IF(NISOT.NE.NEL) CALL XABORT('LIBEAQ: INVALID NEL.')
+            ALLOCATE(NOM(5*NISOT))
+            DO 20 ISO=1,NISOT
+            ISO2=(ISO-1)*5+1
+            CALL AEXCPC(0,20,ITSEGM(IDK+ISO2-1),HNISOR)
+            CALL LCMCAR(HNISOR,.TRUE.,NOM(ISO2))
+   20       CONTINUE
+         ENDIF
+         CALL LCMDRD(TSEGM_PTR)
+         CALL LCMDRD(ICHDIM_PTR)
+         CALL LCMDRD(ICHTYP_PTR)
+         CALL LCMDRD(ICHDKL_PTR)
+   70    CONTINUE
+      ELSE IF(TYPOBJ.EQ.'APOLIBE') THEN
+         NSEGM=NSEGM+1
+         ISO2=(NSEGM-1)*5+1
+         CALL LCMCAR(NOMOBJ,.TRUE.,NOMOB(ISO2))
+         KDS(NSEGM)=IDKOBJ
+         LGS(NSEGM)=LGSEG
+      ELSE
+         CALL XABORT('LIBEAQ: WEIRD SEGMENT TYPE: '//TYPOBJ//' (1).')
+      ENDIF
+      DEALLOCATE(ITCARO)
+   80 CONTINUE
+      IF(.NOT.LPHEAD) CALL XABORT('LIBEAQ: PHEAD SEGMENT NOT FOUND.')
+      DEALLOCATE(VINTE)
+*----
+*  SET THE CORRESPONDANCE BETWEEN THE APOLIB AND THE LIST OF ISOTOPES.
+*----
+      IF(IMPX.GT.2) WRITE(IOUT,'(/16H LIBEAQ: ISOTOPE,12X,4HQ-NG,9X, 
+     1 9HQ-FISSION)')
+      KISEG2=0
+      DO 260 ISO=1,NISOT
+      ISO2=(ISO-1)*5+1
+      CALL LCMCAR(TEXT16,.FALSE.,NOM(ISO2))
+      TEXT20='ISOTOP'//TEXT16(:14)
+      CALL LCMCAR(TEXT20,.TRUE.,NITCA(1))
+      DO 90 ISEG=1,NSEGM
+      ISEG2=(ISEG-1)*5+1
+      IF(NITCA(1).EQ.NOMOB(ISEG2)) THEN
+         IF(NITCA(2).EQ.NOMOB(ISEG2+1)) THEN
+            IF(NITCA(3).EQ.NOMOB(ISEG2+2)) THEN
+               IF(NITCA(4).EQ.NOMOB(ISEG2+3)) THEN
+                  IF(NITCA(5).EQ.NOMOB(ISEG2+4)) THEN
+                     KISEG2=ISEG
+                     GO TO 120
+                  ENDIF
+               ENDIF
+            ENDIF
+         ENDIF
+      ENDIF
+   90 CONTINUE
+      WRITE (HSMG,500) HNISOR,CFILNA
+      CALL XABORT(HSMG)
+*----
+*  ACTIVATION OF CORRESPONDING 'ISOTOP'//NAME SEGMENT.
+*----
+  120 IDKOBJ=KDS(KISEG2)
+      LGSEG=LGS(KISEG2)
+      ALLOCATE(ITCARO(LGSEG))
+      CALL AEXDIR(IUNIT,LBLOC,ITCARO,IDKOBJ,LGSEG)
+      IDK=ITCARO(IDKNO)
+      CALL AEXCPC(IDK,20,ITCARO(1),NOMOBJ)
+      IDK=ITCARO(IDKTY)
+      CALL AEXCPC(IDK,8,ITCARO(1),TYPOBJ)
+      JDKDS=ITCARO(IDKDS)
+      JDKTS=ITCARO(IDKTS)
+      NS=ITCARO(IDKNS)
+*----
+*  RECOVER THE INFINITE DILUTION CROSS SECTION NUMEROTATION.
+*----
+      LPFIX=.FALSE.
+      DO 160 IS=1,NS
+      IDK=JDKTS+8*(IS-1)
+      CALL AEXCPC(IDK,8,ITCARO(1),TYPSEG)
+      LTESTS=ITCARO(IDKLS+IS)
+      IF(LTESTS.LE.0) GO TO 160
+      JDKS=ITCARO(JDKDS+IS)
+      CALL AEXTRT(LIBA21,TYPSEG,NBRTYP,ICHDIM_PTR,ICHTYP_PTR,ICHDKL_PTR)
+      CALL C_F_POINTER(ICHDIM_PTR,ICHDIM,(/ NBRTYP /))
+      CALL C_F_POINTER(ICHTYP_PTR,ICHTYP,(/ NBRTYP /))
+      CALL C_F_POINTER(ICHDKL_PTR,ICHDKL,(/ NBRTYP /))
+      TSEGM_PTR=LCMARA(LTESTS+1)
+      CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LTESTS+1 /))
+      CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LTESTS+1 /))
+      CALL AEXDIR(IUNIT,LBLOC,ITSEGM,JDKS,LTESTS+1)
+*----
+*  RECOVER Q VALUES.
+*----
+      IF(TYPSEG.EQ.'PFIX') THEN
+         LPFIX=.TRUE.
+*        NG ENERGY.
+         CALL AEXGNV(11,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NV)
+         IF(NV.NE.0) THEN
+            IF(RTSEGM(IDK).NE.0.0) QQNG(ISO)=RTSEGM(IDK)
+         ENDIF
+*        FISSION ENERGIES.
+         CALL AEXGNV(20,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NMGEF)
+         IF(NMGEF.NE.0) THEN
+            IF(RTSEGM(IDK+NMGEF-1).NE.0.0) QQF(ISO)=RTSEGM(IDK+NMGEF-1)
+         ENDIF
+      ENDIF
+      CALL LCMDRD(TSEGM_PTR)
+      CALL LCMDRD(ICHDIM_PTR)
+      CALL LCMDRD(ICHTYP_PTR)
+      CALL LCMDRD(ICHDKL_PTR)
+  160 CONTINUE
+      IF(.NOT.LPFIX) CALL XABORT('LIBEAQ: NO PFIX SEGMENT.')
+      DEALLOCATE(ITCARO)
+      IF(IMPX.GT.2) WRITE(IOUT,'(9X,A16,1P,2E13.4)') TEXT16,
+     1 QQNG(ISO),QQF(ISO)
+  260 CONTINUE
+*
+      DEALLOCATE(LGS,KDS,NOMOB,NOM)
+      IERR=KDRCLS(IUNIT,1)
+      IF(IERR.LT.0) THEN
+         TEXT12=CFILNA
+         CALL XABORT('LIBEAQ: APOLLO-2 LIBRARY '//TEXT12//' CANNOT B'//
+     1   'E CLOSED')
+      ENDIF
+      RETURN
+*
+  500 FORMAT(26HLIBEAQ: MATERIAL/ISOTOPE ',A20,20H' IS MISSING ON APOL,
+     > 15HIB-2 FILE NAME ,A12,1H.)
+      END