diff options
Diffstat (limited to 'Dragon/src/LIBA30.f')
| -rw-r--r-- | Dragon/src/LIBA30.f | 59 |
1 files changed, 49 insertions, 10 deletions
diff --git a/Dragon/src/LIBA30.f b/Dragon/src/LIBA30.f index 8f5043f..f90461c 100644 --- a/Dragon/src/LIBA30.f +++ b/Dragon/src/LIBA30.f @@ -65,7 +65,7 @@ TYPE(C_PTR) KPLIB CHARACTER RECNAM*80,RECNA2*80,TEXT80*80,HNAMIS*12,HNISOR*12, 1 HSMG*131,TEXT12*12,CFILNA1*64,CFILNA2*64 - LOGICAL L104,LSIGS,LABSO,LFISS,LDIF + LOGICAL L104,LSIGS,LABSO,LFISS,LDIF,LH INTEGER RANK,TYPE,NBYTE,DIMSR(5) DOUBLE PRECISION XDRCST,DSUM REAL TKT(5) @@ -75,7 +75,7 @@ INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO,ORANIS,ENRANG, 1 FSTTMP,TMPMON,ADDTMP,ITEMPA,ISPAOF,IAFAG,IFAGR,FLXADD INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IPR - REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,DELTA,SECT,XSTOT,TAUX, + REAL, ALLOCATABLE, DIMENSION(:) :: ENERG,DELTA,SECT,HFACT,TAUX, 1 AMASS,TEMP,TEMPM,XS,WGTFLX,BGXS,ABSOXS,DIFFXS,FISSXS,DK104 REAL, ALLOCATABLE, DIMENSION(:,:) :: SIGS REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT @@ -84,7 +84,7 @@ * SCRATCH STORAGE ALLOCATION *---- ALLOCATE(IPR(2,NBISO),ITYPRO(NL)) - ALLOCATE(SECT(NGRO),SIGS(NGRO,NL),SCAT(NGRO,NGRO,NL),XSTOT(NGRO)) + ALLOCATE(SECT(NGRO),SIGS(NGRO,NL),SCAT(NGRO,NGRO,NL),HFACT(NGRO)) * ANEUT=REAL(XDRCST('Neutron mass','amu')) NGF=NGRO+1 @@ -419,7 +419,7 @@ LABSO=.TRUE. LDIF=.TRUE. CALL KDRCPU(TK1) - DO 600 IMX=1,NBISO + DO 570 IMX=1,NBISO KISEG=IPR(2,IMX) IF(KISEG.GT.0) THEN WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) @@ -482,27 +482,66 @@ ENDDO DEALLOCATE(TAUX,DK104,FISSXS,DIFFXS,ABSOXS,BGXS,TEMP) ENDIF - 600 CONTINUE + 570 CONTINUE CALL KDRCPU(TK2) TKT(3)=TK2-TK1 *---- +* PROCESS H-FACTOR INFORMATION +*---- + CALL KDRCPU(TK1) + DO 580 IMX=1,NBISO + IF(MASKI(IMX)) THEN + KPLIB=IPISO(IMX) ! set IMX-th isotope + CALL LCMLEN(KPLIB,'H-FACTOR',ILENG,ITYLCM) + IF(ILENG.NE.0) CALL LCMDEL(KPLIB,'H-FACTOR') + HFACT(:NGRO)=0.0 + WRITE(HNISOR,'(3A4)') (ISONRF(I0,IMX),I0=1,3) + WRITE(RECNAM,'(10HIsotopeXS/,A,8H/Energy/)') TRIM(HNISOR) + IF(hdf5_group_exists(IPAP1,TRIM(RECNAM))) THEN + LH=.FALSE. + VALUE=0.0 + IF(hdf5_group_exists(IPAP1,TRIM(RECNAM)//'/FISS')) THEN + WRITE(RECNA2,'(A,16HFISS/EnergyValue)') TRIM(RECNAM) + CALL hdf5_read_data(IPAP1,TRIM(RECNA2),VALUE) + IF(VALUE.NE.0.0) THEN + CALL LCMGET(KPLIB,'NFTOT',SECT) + HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6 + LH=.TRUE. + ENDIF + ENDIF + IF(hdf5_group_exists(IPAP1,TRIM(RECNAM)//'/MT-102')) THEN + WRITE(RECNA2,'(A,18HMT-102/EnergyValue)') TRIM(RECNAM) + CALL hdf5_read_data(IPAP1,TRIM(RECNA2),VALUE) + IF(VALUE.NE.0.0) THEN + CALL LCMGET(KPLIB,'NG',SECT) + HFACT(:NGRO)=HFACT(:NGRO)+SECT(:NGRO)*VALUE*1.0E6 + LH=.TRUE. + ENDIF + ENDIF + IF(LH) CALL LCMPUT(KPLIB,'H-FACTOR',NGRO,2,HFACT) + ENDIF + ENDIF + 580 CONTINUE + CALL KDRCPU(TK2) + TKT(2)=TKT(2)+TK2-TK1 +*---- * CHECK IF ALL REACTIONS HAVE BEEN PROCESSED. *---- - DO 575 IMX=1,NBISO - DO 570 I=1,2 + DO 600 IMX=1,NBISO + DO 590 I=1,2 IF(IPR(I,IMX).NE.0) THEN WRITE(HSMG,950) I,(ISONAM(I0,IMX),I0=1,3) CALL XABORT(HSMG) ENDIF - 570 CONTINUE - 575 CONTINUE + 590 CONTINUE + 600 CONTINUE IF(IMPX.GT.2) WRITE(IOUT,940) (TKT(I),I=1,3) *---- * SCRATCH STORAGE DEALLOCATION *---- IF(NBFLX.GT.0) DEALLOCATE(WGTFLX,FLXADD) DEALLOCATE(DELTA,ENERG) - DEALLOCATE(XSTOT,SCAT,SIGS,SECT) + DEALLOCATE(HFACT,SCAT,SIGS,SECT) DEALLOCATE(ITYPRO,IPR) RETURN * |