diff options
Diffstat (limited to 'Dragon/src/LIBADD.f')
| -rw-r--r-- | Dragon/src/LIBADD.f | 181 |
1 files changed, 181 insertions, 0 deletions
diff --git a/Dragon/src/LIBADD.f b/Dragon/src/LIBADD.f new file mode 100644 index 0000000..b7262c5 --- /dev/null +++ b/Dragon/src/LIBADD.f @@ -0,0 +1,181 @@ +*DECK LIBADD + SUBROUTINE LIBADD (IPLIB,NBISO,MASKI,IMPX,NGRO,NL,ITRANC,ISONAM, + 1 IPISO,NIR,GIR) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Add transport correction and Goldstein-Cohen data to a /microlib/ +* directory. +* +*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 +* IPLIB pointer to the lattice microscopic cross section library +* (L_LIBRARY signature). +* NBISO number of isotopes present in the calculation domain. +* MASKI isotopic mask. Isotope with index I is processed if +* MASKI(I)=.true. +* IMPX print flag. +* NGRO number of energy groups. +* NL number of Legendre orders required in the calculation +* NL=1 (for isotropic scattering) or higher. +* ITRANC transport correction option (=0: no correction; =1: Apollo- +* type; =2: recover TRANC record; =3: Wims-type; =4: leakage +* correction alone). +* ISONAM alias 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). +* GIR value of the imposed Goldstein-Cohen parameter for groups +* with an IR model. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,IPISO(NBISO) + INTEGER NBISO,IMPX,NGRO,NL,ITRANC,ISONAM(3,NBISO),NIR(NBISO) + LOGICAL MASKI(NBISO) + REAL GIR(NBISO) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (IOUT=6) + TYPE(C_PTR) JPLIB,KPLIB + CHARACTER TEXT12*12,HSMG*131 +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: WORK,WR2,DELTA + REAL, ALLOCATABLE, DIMENSION(:,:) :: SCAT +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(WORK(NGRO),WR2(NGRO),SCAT(NGRO,NGRO),DELTA(NGRO+1)) +*---- +* RECOVER THE ENERGY GRID. +*---- + CALL LCMLEN(IPLIB,'ENERGY',LENGT,ITYLCM) + IF(LENGT.EQ.0) CALL XABORT('LIBADD: NO GROUP STRUCTURE AVAILABLE') + CALL LCMGET(IPLIB,'ENERGY',DELTA) + NGX=0 + DO 10 IGR=1,NGRO + IF((NGX.EQ.0).AND.(DELTA(IGR+1).LT.4.0)) NGX=IGR-1 + 10 CONTINUE + DO 15 IGR=1,NGRO + DELTA(IGR)=LOG(DELTA(IGR)/DELTA(IGR+1)) + 15 CONTINUE +* + DO 110 ISO=1,NBISO + IF(MASKI(ISO)) THEN + WRITE(TEXT12,'(3A4)') ISONAM(1,ISO),ISONAM(2,ISO),ISONAM(3,ISO) + KPLIB=IPISO(ISO) ! set ISO-th isotope + IF(.NOT.C_ASSOCIATED(KPLIB)) GO TO 110 + CALL LCMLEN(KPLIB,'NTOT0',ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + JPLIB=LCMGID(IPLIB,'ISOTOPESLIST') + CALL LCMLIB(JPLIB) + WRITE(HSMG,'(17H LIBADD: ISOTOPE ,A12,6H (ISO=,I6, + 1 17H) IS NOT DEFINED.)') TEXT12,ISO + CALL XABORT(HSMG) + ENDIF +* +* REDIFINE THE GOLDSTEIN-COHEN PARAMETERS. + IF(NIR(ISO).GT.0) THEN + DO 20 IGR=1,MIN(NGRO,NIR(ISO)-1) + WORK(IGR)=1.0 + 20 CONTINUE + DO 30 IGR=NIR(ISO),NGRO + WORK(IGR)=GIR(ISO) + 30 CONTINUE + 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) + ELSE IF(GIR(ISO).EQ.-999.0) THEN + WRITE(IOUT,210) TEXT12,'PTSL',NIR(ISO) + ELSE IF(GIR(ISO).EQ.-1000.0) THEN + WRITE(IOUT,210) TEXT12,'PTMC',NIR(ISO) + ELSE + WRITE(IOUT,200) TEXT12,GIR(ISO),NIR(ISO) + ENDIF + ENDIF + ENDIF +* +* COMPUTE OR RECOVER THE TRANSPORT CORRECTION. + IF(ITRANC.EQ.2) THEN +* RECOVER THE TRANSPORT CORRECTION FROM THE LIBRARY. + CALL LCMLEN(KPLIB,'TRANC',ILENG,ITYLCM) + IF(ILENG.EQ.0) THEN + WORK(:NGRO)=0.0 + CALL LCMPUT(KPLIB,'TRANC',NGRO,2,WORK) + ENDIF + ELSE IF(ITRANC.NE.0) THEN + WORK(:NGRO)=0.0 + CALL LCMLEN(KPLIB,'NTOT1',ILENG,ITYLCM) + IF(ILENG.NE.0) THEN +* LEAKAGE CORRECTION. + CALL LCMGET(KPLIB,'NTOT1',WORK) + CALL LCMGET(KPLIB,'NTOT0',WR2) + DO 40 IG1=1,NGRO + WORK(IG1)=WR2(IG1)-WORK(IG1) + 40 CONTINUE + ENDIF + IF((NL.GE.2).AND.(ITRANC.NE.4)) THEN + 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 + CALL XABORT(HSMG) + ENDIF + CALL XDRLGS(KPLIB,-1,0,1,1,1,NGRO,WR2,SCAT,ITY) + IF(ITRANC.EQ.1) THEN +* APOLLO-TYPE TRANSPORT CORRECTION. USE THE MICRO- +* REVERSIBILITY PRINCIPLE AT ALL ENERGIES. + DO 50 IG1=1,NGRO + WORK(IG1)=WORK(IG1)+WR2(IG1) + 50 CONTINUE + ELSE IF(ITRANC.EQ.3) THEN +* WIMS-TYPE TRANSPORT CORRECTION. USE THE MICRO- +* REVERSIBILITY PRINCIPLE BELOW 4 EV AND A 1/E SPECTRUM +* ABOVE. + DO 65 IG1=1,MIN(NGRO,NGX) + DO 60 IG2=1,NGRO + WORK(IG1)=WORK(IG1)+SCAT(IG1,IG2)*DELTA(IG2)/DELTA(IG1) + 60 CONTINUE + 65 CONTINUE + DO 70 IG1=NGX+1,NGRO + WORK(IG1)=WORK(IG1)+WR2(IG1) + 70 CONTINUE + ELSE + CALL XABORT('LIBADD: UNKNOWN TYPE OF CORRECTION.') + ENDIF + ENDIF +* ***CAUTION*** 'TRANC' CONTAINS BOTH TRANSPORT AND LEAKAGE +* CORRECTIONS. + CALL LCMPUT(KPLIB,'TRANC',NGRO,2,WORK) + ENDIF + ENDIF + 110 CONTINUE +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(DELTA,SCAT,WR2,WORK) + RETURN +* + 200 FORMAT(/51H LIBADD: THE GOLDSTEIN-COHEN PARAMETER OF ISOTOPE ', + 1 A12,12H' WAS SET TO,F5.2,33H FOR GROUPS WITH INDEX GREATER OR, + 2 9H EQUAL TO,I4,1H.) + 210 FORMAT(/18H LIBADD: ISOTOPE ',A12,20H' IS PROCESSED WITH ,A, + 1 48H METHOD IN GROUPS WITH INDEX GREATER OR EQUAL TO,I4,1H.) + END |