From 0752d13bc6cab860c5312cd89dcfae41b9e08984 Mon Sep 17 00:00:00 2001 From: HEBERT Alain Date: Fri, 28 Nov 2025 09:21:06 -0500 Subject: Resolve "Implement analytic inelastic scattering laws for Draglibs in module LIB:" --- Dragon/src/LIBDRA.f | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) (limited to 'Dragon/src/LIBDRA.f') diff --git a/Dragon/src/LIBDRA.f b/Dragon/src/LIBDRA.f index 9d23805..51438a9 100644 --- a/Dragon/src/LIBDRA.f +++ b/Dragon/src/LIBDRA.f @@ -87,7 +87,7 @@ ALLOCATE(NFS(NGRO),ITYPRO(NL)) ALLOCATE(AWR(NBISO),DELTA(NGRO),SIGS(NGRO,NL),SCAT(NGRO,NGRO,NL), 1 TOTAL(NGRO),SIGF(NGRO,0:MAXDEL),CHI(NGRO,0:MAXDEL), - 2 SADD(NGRO,NED),GOLD(NGRO),ZNPHI(NGRO)) + 2 SADD(NGRO,NED),ENER(NGRO+1),GOLD(NGRO),ZNPHI(NGRO)) ALLOCATE(LSCAT(NL),LADD(NED)) *---- * RECOVER THE GROUP STRUCTURE. @@ -112,7 +112,6 @@ WRITE (IOUT,'(40H LIBDRA: NUMBER OF ISOTOPES IN MICROLIB=,I6)') 1 NBISO ENDIF - ALLOCATE(ENER(NGRO+1)) CALL LCMLEN(IPDRL,'ENERGY',LENGT,ITYLCM) LENGT=LENGT-1 IF(LENGT.NE.NGRO) CALL XABORT('LIBDRA: INVALID GROUP STRUCTURE.') @@ -128,7 +127,6 @@ ENDIF CALL LCMPUT(IPLIB,'ENERGY',NGRO+1,2,ENER) CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,DELTA) - DEALLOCATE(ENER) CALL LCMLEN(IPDRL,'CHI-LIMITS',NBESP,ITYLCM) IF(NBESP.GT.0) THEN NBESP=NBESP-1 @@ -210,11 +208,11 @@ NDEL=MAX(NDEL,NDEL0) IF(NDEL0.GT.MAXDEL) CALL XABORT('LIBDRA: MAXDEL OVERFLOW.') IF(NDEL0.GT.0) CALL LCMGET (IPDRL,'LAMBDA-D',ZLAMB) - CALL LIBDRB (IPDRL,NGRO,NL,NDEL0,NBESP,SN(1,IMX),SB(1,IMX), - 1 NED,HVECT,DELTA,LBIN,NFS,EBIN,AWR(IMX),DELECC,IGECCO,IMPX, - 2 NGF,NGFR,LSCAT,LSIGF,LADD,LGOLD,SIGS(1,1),SCAT(1,1,1),TOTAL, - 3 ZNPHI,SIGF(1,1),CHI(1,1),CHI4G(1,1),SADD(1,1),GOLD(1), - 4 BIN(1)) + CALL LIBDRB (IPDRL,NGRO,NL,NDEL0,NBESP,ENER,SN(1,IMX), + 1 SB(1,IMX),NED,HVECT,DELTA,LBIN,NFS,EBIN,AWR(IMX),DELECC, + 2 IGECCO,IMPX,NGF,NGFR,LSCAT,LSIGF,LADD,LGOLD,SIGS(1,1), + 3 SCAT(1,1,1),TOTAL,ZNPHI,SIGF(1,1),CHI(1,1),CHI4G(1,1), + 4 SADD(1,1),GOLD(1),BIN(1)) ELSE *---- * PERFORM TEMPERATURE LAGRANGIAN INTERPOLATION (ORDER ABS(NOTX)). @@ -263,10 +261,11 @@ > 1P,E12.4,18H KELVIN. FACTOR = ,E12.4)') TEMP(ITM),TERPM WRITE (CD,'(I4.4)') ITM CALL LCMSIX (IPDRL,'SUBTMP'//CD,1) - CALL LIBDRB (IPDRL,NGRO,NL,NDEL0,NBESP,SN(1,IMX),SB(1,IMX), - 1 NED,HVECT,DELTA,LBIN,NFS,EBIN,AWR(IMX),DELECC,IGECCO,IMPX, - 2 NGF,NGFR,LSCAT,LSIGF,LADD,LGOLD,SIGS2(1),SCAT2(1),TOTAL2, - 3 ZNPHI2,SIGF2(1),CHI2(1),CHI4G2(1),SADD2(1),GOLD2(1),BIN2(1)) + CALL LIBDRB (IPDRL,NGRO,NL,NDEL0,NBESP,ENER,SN(1,IMX), + 1 SB(1,IMX),NED,HVECT,DELTA,LBIN,NFS,EBIN,AWR(IMX),DELECC, + 2 IGECCO,IMPX,NGF,NGFR,LSCAT,LSIGF,LADD,LGOLD,SIGS2(1), + 3 SCAT2(1),TOTAL2,ZNPHI2,SIGF2(1),CHI2(1),CHI4G2(1),SADD2(1), + 4 GOLD2(1),BIN2(1)) CALL LCMSIX (IPDRL,' ',2) DO 130 IG=1,NGRO TOTAL(IG)=TOTAL(IG)+TERPM*TOTAL2(IG) @@ -403,8 +402,8 @@ * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(LADD,LSCAT) - DEALLOCATE(CHI4G,ZNPHI,GOLD,SADD,CHI,SIGF,TOTAL,SCAT,SIGS,DELTA, - 1 AWR) + DEALLOCATE(CHI4G,ZNPHI,GOLD,ENER,SADD,CHI,SIGF,TOTAL,SCAT,SIGS, + 1 DELTA,AWR) DEALLOCATE(ITYPRO,NFS) RETURN * -- cgit v1.2.3