diff options
Diffstat (limited to 'Dragon/src/LIBA20.f')
| -rw-r--r-- | Dragon/src/LIBA20.f | 47 |
1 files changed, 41 insertions, 6 deletions
diff --git a/Dragon/src/LIBA20.f b/Dragon/src/LIBA20.f index 73b65fc..0b2a2c1 100644 --- a/Dragon/src/LIBA20.f +++ b/Dragon/src/LIBA20.f @@ -74,7 +74,7 @@ 1 TYPSEG*8,HNAMIS*12,HNISOR*12,HNISSS*12,HSMG*131,TEXT2*2, 2 TEXT12*12 LOGICAL LPFIX,LTRAN,LGPROB,LGTDIF,LGTTRA,LN2N,LPTHOM,L104,LABS, - 1 LDIF,LFIS,LPWD,LPED + 1 LDIF,LFIS,LPWD,LPED,LH INTEGER ZFISS,FGTD,FGHOMO,FGRESO,FAGG,FDGG,WGAL,FAG DOUBLE PRECISION UU,XDRCST INTEGER ITHOMO(MAXHOM),ITEXT(20),ISFICH(3),IPAR(3) @@ -92,10 +92,11 @@ *---- INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO,NFS,KDS,LGS,NOM,NOMS, 1 NOMOB,VINTE,ITCARO,ITC104,ITS104,ITITLE,IZSECT,ISECTT,IFDG,IIAD, - 2 IDEPL + 2 IDEPL,IPR2 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,DELTA,SECT,XSTOT,TAUX, - 1 DELTF,SIGTF,SIGAF,ENER,AMASS,TEMP,TEMPS,SEQHO,SQRTE,PWD,PED + 1 DELTF,SIGTF,SIGAF,ENER,AMASS,TEMP,TEMPS,SEQHO,SQRTE,PWD,PED,QQNG, + 2 QQF,HFACT REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT LOGICAL, ALLOCATABLE, DIMENSION(:) :: LGTRE @@ -106,7 +107,7 @@ *---- * SCRATCH STORAGE ALLOCATION *---- - ALLOCATE(IPR(7+2*(NL-1),NBISO),ITYPRO(NL),NFS(NGRO)) + ALLOCATE(IPR(7+2*(NL-1),NBISO),IPR2(NBISO),ITYPRO(NL),NFS(NGRO)) ALLOCATE(ENERG(NGRO+1),DELTA(NGRO),SECT(NGRO),SIGS(NGRO,NL), 1 SCAT(NGRO,NGRO,NL),XSTOT(NGRO)) * @@ -317,7 +318,8 @@ IF(IMPX.GT.1) WRITE(IOUT,820) NISOT,NISOTS,NSEGM CALL LIBA27(NAMFIL,NBISO,NISOT,NSEGM,NL,ISONRF,ISHINA,MASKI, 1 NOM,NOMOB,IPR) - DEALLOCATE(NOM) + IPR2(:NBISO)=IPR(1,:NBISO) + !DEALLOCATE(NOM) IF(NISOTS.GT.0) DEALLOCATE(NOMS) CALL KDRCPU(TK2) TKT(1)=TK2-TK1 @@ -1304,13 +1306,46 @@ 600 CONTINUE ENDIF CALL LCMPUT(KPLIB,'NG',NGRO,2,SECT) + + CALL LCMLEN(KPLIB,'H-FACTOR',LENGT,ITYLCM) + IF(LENGT.NE.0) CALL LCMDEL(KPLIB,'H-FACTOR') ENDIF 610 CONTINUE *---- +* PROCESS H-FACTOR INFORMATION +*---- + ALLOCATE(QQNG(NISOT),QQF(NISOT)) + CALL LIBEAQ(NAMFIL,NISOT,IMPX,QQNG,QQF) + DO 620 IMX=1,NBISO + IF(MASKI(IMX)) THEN + KPLIB=IPISO(IMX) ! set IMX-th isotope + ISO=IPR2(IMX) + ALLOCATE(HFACT(NGRO)) + HFACT(:NGRO)=0.0 +* NG ENERGY. + VALUE=QQNG(ISO) + IF(VALUE.NE.0.0) THEN + CALL LCMGET(KPLIB,'NG',SECT) + HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6 + LH=.TRUE. + ENDIF +* FISSION ENERGIES. + VALUE=QQF(ISO) + IF(VALUE.NE.0.0) THEN + CALL LCMGET(KPLIB,'NFTOT',SECT) + HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6 + LH=.TRUE. + ENDIF + IF(LH) CALL LCMPUT(KPLIB,'H-FACTOR',NGRO,2,HFACT) + DEALLOCATE(HFACT) + ENDIF + 620 CONTINUE + DEALLOCATE(QQF,QQNG) +*---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(XSTOT,SCAT,SIGS,SECT,DELTA,ENERG) - DEALLOCATE(NFS,ITYPRO,IPR) + DEALLOCATE(NFS,ITYPRO,IPR2,IPR) RETURN * 800 FORMAT(/43H LIBA20: PROCESSING APOLIB-2 LIBRARY NAME: ,A12,1H.) |