diff options
Diffstat (limited to 'Dragon/src/LIBADD.f')
| -rw-r--r-- | Dragon/src/LIBADD.f | 87 |
1 files changed, 72 insertions, 15 deletions
diff --git a/Dragon/src/LIBADD.f b/Dragon/src/LIBADD.f index b7262c5..ba6829b 100644 --- a/Dragon/src/LIBADD.f +++ b/Dragon/src/LIBADD.f @@ -1,12 +1,12 @@ *DECK LIBADD - SUBROUTINE LIBADD (IPLIB,NBISO,MASKI,IMPX,NGRO,NL,ITRANC,ISONAM, - 1 IPISO,NIR,GIR) + SUBROUTINE LIBADD (IPLIB,NBISO,MASKI,IMPX,NGRO,NL,ITRANC,NDEPL, + 1 ISONAM,ISONRF,IPISO,NIR,GIR) * *----------------------------------------------------------------------- * *Purpose: -* Add transport correction and Goldstein-Cohen data to a /microlib/ -* directory. +* Add transport correction, Goldstein-Cohen and H-FACTOR data to a +* /microlib/ directory. * *Copyright: * Copyright (C) 2002 Ecole Polytechnique de Montreal @@ -30,7 +30,9 @@ * ITRANC transport correction option (=0: no correction; =1: Apollo- * type; =2: recover TRANC record; =3: Wims-type; =4: leakage * correction alone). +* NDEPL number of depleting isotopes. * ISONAM alias name of each isotope. +* ISONRF library reference name of each isotope. * IPISO pointer array towards microlib isotopes. * NIR group index with an imposed IR slowing-down model (=0 for no * IR model). @@ -44,20 +46,24 @@ * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPLIB,IPISO(NBISO) - INTEGER NBISO,IMPX,NGRO,NL,ITRANC,ISONAM(3,NBISO),NIR(NBISO) + INTEGER NBISO,IMPX,NGRO,NL,ITRANC,NDEPL,ISONAM(3,NBISO), + 1 ISONRF(3,NBISO),NIR(NBISO) LOGICAL MASKI(NBISO) REAL GIR(NBISO) *---- * LOCAL VARIABLES *---- - PARAMETER (IOUT=6) + PARAMETER (IOUT=6,NSTATE=40) + INTEGER ISTATE(NSTATE) TYPE(C_PTR) JPLIB,KPLIB - CHARACTER TEXT12*12,HSMG*131 + CHARACTER HSONAM*12,HSONRF*12,HSMG*131 *---- * ALLOCATABLE ARRAYS *---- REAL, ALLOCATABLE, DIMENSION(:) :: WORK,WR2,DELTA - REAL, ALLOCATABLE, DIMENSION(:,:) :: SCAT + REAL, ALLOCATABLE, DIMENSION(:,:) :: SCAT,RER + CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HREAC + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: HGAR *---- * SCRATCH STORAGE ALLOCATION *---- @@ -75,10 +81,32 @@ DO 15 IGR=1,NGRO DELTA(IGR)=LOG(DELTA(IGR)/DELTA(IGR+1)) 15 CONTINUE +*---- +* RECOVER DEPLETION DATA. +*---- + NREAC=0 + IF(NDEPL.NE.0) THEN + CALL LCMLEN(IPLIB,'DEPL-CHAIN',LENGTH,ITYLCM) + IF(LENGTH.EQ.0) THEN + CALL LCMLIB(IPLIB) + CALL XABORT('LIBADD: MISSING DEPL-CHAIN DATA.') + ENDIF + CALL LCMSIX(IPLIB,'DEPL-CHAIN',1) + CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NDEPL) CALL XABORT('LIBADD: INVALID NUMBER OF ' + 1 //'DEPLETING ISOTOPES.') + NREAC=ISTATE(8) + ALLOCATE(HGAR(NDEPL),RER(NREAC,NDEPL),HREAC(NREAC)) + CALL LCMGTC(IPLIB,'ISOTOPESDEPL',12,NDEPL,HGAR) + CALL LCMGET(IPLIB,'DEPLETE-ENER',RER) + CALL LCMGTC(IPLIB,'DEPLETE-IDEN',8,NREAC,HREAC) + CALL LCMSIX(IPLIB,' ',2) + ENDIF * DO 110 ISO=1,NBISO IF(MASKI(ISO)) THEN - WRITE(TEXT12,'(3A4)') ISONAM(1,ISO),ISONAM(2,ISO),ISONAM(3,ISO) + WRITE(HSONAM,'(3A4)') (ISONAM(I,ISO),I=1,3) + WRITE(HSONRF,'(3A4)') (ISONRF(I,ISO),I=1,3) KPLIB=IPISO(ISO) ! set ISO-th isotope IF(.NOT.C_ASSOCIATED(KPLIB)) GO TO 110 CALL LCMLEN(KPLIB,'NTOT0',ILENG,ITYLCM) @@ -86,7 +114,7 @@ JPLIB=LCMGID(IPLIB,'ISOTOPESLIST') CALL LCMLIB(JPLIB) WRITE(HSMG,'(17H LIBADD: ISOTOPE ,A12,6H (ISO=,I6, - 1 17H) IS NOT DEFINED.)') TEXT12,ISO + 1 17H) IS NOT DEFINED.)') HSONAM,ISO CALL XABORT(HSMG) ENDIF * @@ -101,13 +129,13 @@ CALL LCMPUT(KPLIB,'NGOLD',NGRO,2,WORK) IF(IMPX.GT.1) THEN IF(GIR(ISO).EQ.-998.0) THEN - WRITE(IOUT,210) TEXT12,'PT',NIR(ISO) + WRITE(IOUT,210) HSONAM,'PT',NIR(ISO) ELSE IF(GIR(ISO).EQ.-999.0) THEN - WRITE(IOUT,210) TEXT12,'PTSL',NIR(ISO) + WRITE(IOUT,210) HSONAM,'PTSL',NIR(ISO) ELSE IF(GIR(ISO).EQ.-1000.0) THEN - WRITE(IOUT,210) TEXT12,'PTMC',NIR(ISO) + WRITE(IOUT,210) HSONAM,'PTMC',NIR(ISO) ELSE - WRITE(IOUT,200) TEXT12,GIR(ISO),NIR(ISO) + WRITE(IOUT,200) HSONAM,GIR(ISO),NIR(ISO) ENDIF ENDIF ENDIF @@ -135,7 +163,7 @@ CALL LCMLEN(KPLIB,'SCAT-SAVED',ILENG,ITYLCM) IF(ILENG.EQ.0) THEN WRITE(HSMG,'(37H LIBADD: NO SCAT-SAVED RECORD FOR ISO, - 1 5HTOPE ,A12,1H.)') TEXT12 + 1 5HTOPE ,A12,1H.)') HSONAM CALL XABORT(HSMG) ENDIF CALL XDRLGS(KPLIB,-1,0,1,1,1,NGRO,WR2,SCAT,ITY) @@ -165,11 +193,40 @@ * CORRECTIONS. CALL LCMPUT(KPLIB,'TRANC',NGRO,2,WORK) ENDIF +* +* ADD OR CORRECT H-FACTOR INFORMATION IN THE MICROLIB. + IF(NDEPL.NE.0) THEN + JDEPL=0 + DO IDEPL=1,NDEPL + JDEPL=IDEPL + IF(HSONRF.EQ.HGAR(IDEPL)) GO TO 80 + ENDDO + CYCLE + 80 WORK(:NGRO)=0.0 + CALL LCMLEN(KPLIB,'H-FACTOR',LENGTH,ITYLCM) + IF(LENGTH.NE.0) CALL LCMGET(KPLIB,'H-FACTOR',WORK) + DO IREA=2,NREAC + CALL LCMLEN(KPLIB,HREAC(IREA),LENGTH,ITYLCM) + IF(LENGTH.EQ.0) CYCLE + IF(LENGTH.GT.NGRO) CALL XABORT('LIBADD: WR2 OVERFLOW.') + WR2(:NGRO)=0.0 + CALL LCMGET(KPLIB,HREAC(IREA),WR2) + DO IG=1,LENGTH + WORK(IG)=WORK(IG)+RER(IREA,JDEPL)*WR2(IG)*1.0E6 + ENDDO + ENDDO ! IREA + CALL LCMPUT(KPLIB,'H-FACTOR',NGRO,2,WORK) + IF(IMPX.GT.1) THEN + WRITE(IOUT,'(42H LIBADD: ADD H-FACTOR INFORMATION TO ISOTO, + 1 3HPE ,A,1H.)') TRIM(HSONRF) + ENDIF + ENDIF ENDIF 110 CONTINUE *---- * SCRATCH STORAGE DEALLOCATION *---- + IF(NDEPL.NE.0) DEALLOCATE(HREAC,RER,HGAR) DEALLOCATE(DELTA,SCAT,WR2,WORK) RETURN * |