*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