From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001 From: stainer_t Date: Mon, 8 Sep 2025 13:48:49 +0200 Subject: Initial commit from Polytechnique Montreal --- Dragon/src/LIBDI5.f | 149 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 149 insertions(+) create mode 100644 Dragon/src/LIBDI5.f (limited to 'Dragon/src/LIBDI5.f') diff --git a/Dragon/src/LIBDI5.f b/Dragon/src/LIBDI5.f new file mode 100644 index 0000000..97e749d --- /dev/null +++ b/Dragon/src/LIBDI5.f @@ -0,0 +1,149 @@ +*DECK LIBDI5 + SUBROUTINE LIBDI5 (MAXDIL,NAMFIL,HSHI,NDIL,DILUT) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Find the dilutions corresponding to a resonant isotope within a +* library in Apolib-2 format. +* +*Copyright: +* Copyright (C) 2002 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 +* MAXDIL maximum number of dilutions. +* NAMFIL name of the APOLIB-2 file. +* HSHI library name of the self-shielding data. +* +*Parameters: output +* NDIL number of finite dilutions. +* DILUT dilutions. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER MAXDIL,NDIL + CHARACTER HSHI*12 + CHARACTER NAMFIL*(*) + REAL DILUT(MAXDIL) +*---- +* LOCAL VARIABLES +*---- + EXTERNAL LIBA21 + CHARACTER HSMG*131,TEXT8*8,TEXT20*20,NOMOBJ*20,TYPOBJ*8,TYPSEG*8 + LOGICAL LISO,LPTHOM + INTEGER ISFICH(3) + INTEGER, ALLOCATABLE, DIMENSION(:) :: VINTE,ITCARO + 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 / +*---- +* INDEX THE APOLIB-2 FILE. +*---- + CALL AEXTPA(NAMFIL,ISFICH) + IADRES=ISFICH(1) + NBOBJ=ISFICH(2) + LBLOC=ISFICH(3) + NIN=KDROPN(NAMFIL,2,4,LBLOC) + IF(NIN.LE.0) THEN + WRITE (HSMG,'(35HLIBDI5: UNABLE TO OPEN LIBRARY FILE,1X,A16, + 1 1H.)') NAMFIL + CALL XABORT(HSMG) + ENDIF + ALLOCATE(VINTE(2*NBOBJ)) + CALL AEXDIR(NIN,LBLOC,VINTE,IADRES,2*NBOBJ) + IDKNO=1-TKCARO(14) + IDKTY=1-TKCARO(21) + IDKDS=1-TKCARO(10) + IDKTS=1-TKCARO(23) + IDKDA=1-TKCARO(26) + IDKNS=TKCARO(2)+1 + IDKLS=TKCARO(8) +* + TEXT20='SSDATA'//HSHI + LISO=.FALSE. + DO 70 I=3,NBOBJ + IDKOBJ=VINTE(2*I-1) + LGSEG=VINTE(2*I)+1 + ALLOCATE(ITCARO(LGSEG)) + CALL AEXDIR(NIN,LBLOC,ITCARO,IDKOBJ,LGSEG) + IDK=ITCARO(IDKNO) + CALL AEXCPC(IDK,20,ITCARO,NOMOBJ) + IDK=ITCARO(IDKTY) + CALL AEXCPC(IDK,8,ITCARO,TYPOBJ) + JDKDS=ITCARO(IDKDS) + JDKTS=ITCARO(IDKTS) + NS=ITCARO(IDKNS) + IDK=ITCARO(IDKDA) + CALL AEXCPC(IDK,8,ITCARO,TEXT8) + IF((TYPOBJ.EQ.'APOLIBE').AND.(NOMOBJ.EQ.TEXT20)) THEN + LISO=.TRUE. + LPTHOM=.FALSE. + DO 60 IS=1,NS + IDK=JDKTS+8*(IS-1) + CALL AEXCPC(IDK,8,ITCARO,TYPSEG) + LNGS=ITCARO(IDKLS+IS) + IF(LNGS.LE.0) GO TO 60 + 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(LNGS+1) + CALL C_F_POINTER(TSEGM_PTR,ITSEGM,(/ LNGS+1 /)) + CALL AEXDIR(NIN,LBLOC,ITSEGM,JDKS,LNGS+1) + IF(TYPSEG.EQ.'PTHOM1') THEN + CALL C_F_POINTER(TSEGM_PTR,RTSEGM,(/ LNGS+1 /)) + LPTHOM=.TRUE. + CALL AEXGNV(16,ITSEGM,ICHDIM,ICHTYP,ICHDKL,IDK,NSEQHO) + NDIL=NSEQHO-1 + IF(NDIL.GT.MAXDIL) CALL XABORT('LIBDI5: INVALID MAXDIL.') + DILMAX=RTSEGM(IDK+NSEQHO-1) + IF(DILMAX.LT.1.0E10) THEN + WRITE(HSMG,'(35HLIBDI5: INVALID INFINITE DILUTION (,1P, + 1 E12.4,14H) FOR ISOTOPE ,A12,1H.)') DILMAX,HSHI + CALL XABORT(HSMG) + ENDIF + DO 50 J=1,NSEQHO + DILUT(J)=RTSEGM(IDK+J-1) + 50 CONTINUE + ENDIF + CALL LCMDRD(TSEGM_PTR) + CALL LCMDRD(ICHDIM_PTR) + CALL LCMDRD(ICHTYP_PTR) + CALL LCMDRD(ICHDKL_PTR) + 60 CONTINUE + IF(.NOT.LPTHOM) CALL XABORT('LIBDI5: NO PTHOM1 SEGMENT ' + 1 //'FOR ISOTOPE '//HSHI//'.') + ENDIF + DEALLOCATE(ITCARO) + 70 CONTINUE + DEALLOCATE(VINTE) + IF(.NOT.LISO) CALL XABORT('LIBDI5: UNABLE TO FIND ISOTOPE ' + 1 //HSHI//'.') + IER=KDRCLS(NIN,1) + IF(IER.LT.0) THEN + WRITE (HSMG,'(36HLIBDI5: UNABLE TO CLOSE LIBRARY FILE,1X,A16, + 1 1H.)') NAMFIL + CALL XABORT(HSMG) + ENDIF + RETURN + END -- cgit v1.2.3