summaryrefslogtreecommitdiff
path: root/Dragon/src/LIBEAQ.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/LIBEAQ.f')
-rw-r--r--Dragon/src/LIBEAQ.f254
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
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 09:39:17 +0000