summaryrefslogtreecommitdiff
path: root/Dragon/src/LIBPTW.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/LIBPTW.f')
-rw-r--r--Dragon/src/LIBPTW.f243
1 files changed, 243 insertions, 0 deletions
diff --git a/Dragon/src/LIBPTW.f b/Dragon/src/LIBPTW.f
new file mode 100644
index 0000000..d67f9a3
--- /dev/null
+++ b/Dragon/src/LIBPTW.f
@@ -0,0 +1,243 @@
+*DECK LIBPTW
+ SUBROUTINE LIBPTW (IPLIB,IPTMP,IPROC,NGRO,NL,HNAMIS,NED,HVECT,
+ 1 NDIL,DILUT,AWR,IPRECI,IMPX)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Build a temperature-independant draglib (IPROC=2) on the internal
+* library or write the probability table information (IPROC=1/3/4).
+*
+*Copyright:
+* Copyright (C) 2003 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 isotopic directory in microlib.
+* IPTMP pointer to the multi-dilution internal library.
+* IPROC type of microlib processing:
+* =1: perform temperature interpolation and compute physical
+* probability tables.
+* =2: perform temperature interpolation and build a
+* temperature-independent draglib;
+* =3: perform temperature interpolation and compute calendf-
+* type mathematical probability tables based on bin-type
+* cross-sections for total cross sections;
+* =4: perform temperature interpolation and compute physical
+* probability tables or slowing-down correlated probability
+* tables.
+* =5: perform temperature interpolation and compute calendf-
+* type mathematical probability tables based on bin-type
+* cross-sections for all available cross-sections types.
+* NGRO number of energy groups.
+* NL number of Legendre orders required in the calculation
+* (NL=1 or higher).
+* HNAMIS local name of the isotope:
+* HNAMIS(1:8) is the local isotope name;
+* HNAMIS(9:12) is a suffix function of the mix number.
+* NED number of extra vector edits.
+* HVECT names of the extra vector edits.
+* NDIL number of finite dilutions.
+* DILUT dilutions.
+* AWR mass ratio for current isotope.
+* IPRECI accuracy index for probability tables in CALENDF.
+* IMPX print flag.
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ TYPE(C_PTR) IPLIB,IPTMP
+ INTEGER IPROC,NGRO,NL,NED,NDIL,IPRECI,IMPX
+ REAL DILUT(NDIL+1),AWR
+ CHARACTER HNAMIS*12,HVECT(NED)*8
+*----
+* LOCAL VARIABLES
+*----
+ TYPE(C_PTR) JPLIB,KPLIB,JPTMP,KPTMP
+ PARAMETER (MAXNPT=12,MAXTRA=10000)
+ CHARACTER TEXT12*12,TEXX12*12
+ LOGICAL LSIGF,LGOLD,EMPTY,LCM,LBSIGF
+*----
+* ALLOCATABLE ARRAYS
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: NFS,NOR,NBIN
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISMIN,ISMAX,ISM
+ LOGICAL, ALLOCATABLE, DIMENSION(:) :: LSCAT,LADD
+ REAL, ALLOCATABLE, DIMENSION(:) :: GOLD,FLUX,TOTAL,SIGF,SIGS,SCAT,
+ 1 SADD,ZDEL,DELTG,TBIN,SBIN,FBIN,EBIN
+ TYPE(C_PTR) SIGP_PTR
+ REAL, POINTER, DIMENSION(:) :: SIGP
+*----
+* SCRATCH STORAGE ALLOCATION
+*----
+ ALLOCATE(ISMIN(NL,NGRO),ISMAX(NL,NGRO),NFS(NGRO),NOR(NGRO),
+ 1 ISM(2,NL))
+ ALLOCATE(LSCAT(NL),LADD(NED))
+ ALLOCATE(GOLD(NGRO))
+*----
+* COPY INFINITE DILUTION DATA FROM IPTMP TO IPLIB.
+*----
+ JPTMP=LCMGID(IPTMP,'ISOTOPESLIST')
+ CALL LCMLEL(JPTMP,NDIL+1,ILENG,ITYLCM)
+ IF(ILENG.EQ.0) THEN
+ TEXT12=HNAMIS(1:8)
+ WRITE(TEXT12(9:12),'(I4.4)') NDIL+1
+ CALL XABORT('LIBPTW: MISSING LIST ITEM FOR '//TEXT12)
+ ENDIF
+ KPTMP=LCMGIL(JPTMP,NDIL+1) ! set (NDIL+1)-th isotope
+ CALL LCMLEN(KPTMP,'LAMBDA-D',NDEL,ITYLCM)
+ CALL LCMEQU(KPTMP,IPLIB)
+*
+ IF(NDIL.GT.0) THEN
+* RECOVER INFORMATION FROM IPTMP AND PUT NEW INFORMATION INTO
+* IPLIB.
+ ALLOCATE(FLUX(NGRO*(NDIL+1)),TOTAL(NGRO*(NDIL+1)),
+ 1 SIGF(NGRO*(NDIL+1)),SIGS(NGRO*NL*(NDIL+1)),
+ 2 SCAT(NGRO*NGRO*NL*(NDIL+1)),SADD(NGRO*NED*(NDIL+1)),
+ 3 ZDEL(NGRO*NDEL*(NDIL+1)),DELTG(NGRO))
+*
+ IF(IMPX.GT.2) THEN
+ WRITE(6,'(/32H LIBPTW: DILUTIONS FOR ISOTOPE '',A12,2H'':)')
+ 1 HNAMIS
+ WRITE(6,'(1X,1P,12E12.4)') DILUT(:NDIL+1)
+ ENDIF
+ CALL LIBEXT(IPTMP,NGRO,NL,NDIL,NED,HVECT,NDEL,.FALSE.,IMPX,
+ 1 DILUT,MDIL,LSCAT,LSIGF,LADD,LGOLD,FLUX,TOTAL,SIGF,SIGS,SCAT,
+ 2 SADD,ZDEL,DELTG,GOLD,ISMIN,ISMAX)
+*
+* DESTROY THE MULTI-DILUTION INTERNAL LIBRARY.
+ CALL LCMCL(IPTMP,2)
+*
+ IF(IPROC.EQ.1) THEN
+* COMPUTE THE PHYSICAL PROBABILITY TABLES.
+ MAXNOR=MAXNPT
+ CALL LCMINF(IPLIB,TEXT12,TEXX12,EMPTY,ILONG,LCM)
+ CALL LCMSIX(IPLIB,'PT-TABLE',1)
+ CALL LCMPUT(IPLIB,'NDEL',1,1,NDEL)
+ JPLIB=LCMLID(IPLIB,'GROUP-PT',NGRO)
+ DO 20 IGRP=1,NGRO
+ NPART=3+NL+NED+NDEL
+ DO 10 IL=1,NL
+ NPART=NPART+MAX(ISMAX(IL,IGRP)-ISMIN(IL,IGRP)+1,0)
+ 10 CONTINUE
+ IF(LGOLD) THEN
+ GOLD0=GOLD(IGRP)
+ ELSE
+ GOLD0=1.0
+ ENDIF
+ IF(LCM) THEN
+ SIGP_PTR=LCMARA(MAXNOR*NPART)
+ CALL C_F_POINTER(SIGP_PTR,SIGP,(/ MAXNOR*NPART /))
+ ELSE
+ ALLOCATE(SIGP(MAXNOR*NPART))
+ ENDIF
+ SIGP(:MAXNOR*NPART)=0.0
+ CALL LIBTAB(IGRP,NGRO,NL,MDIL,NPART,NED,NDEL,HNAMIS,IMPX,
+ 1 LSCAT,LSIGF,LADD,DILUT,TOTAL,SIGF,SIGS,SCAT,SADD,ZDEL,GOLD0,
+ 2 ISMIN,ISMAX,NOR(IGRP),SIGP)
+*
+ IF(NOR(IGRP).GT.1) THEN
+* SAVE THE PROBABILITY TABLE INTO IPLIB.
+ KPLIB=LCMDIL(JPLIB,IGRP)
+ IF(LCM) THEN
+ CALL LCMPPD(KPLIB,'PROB-TABLE',MAXNOR*NPART,2,SIGP_PTR)
+ ELSE
+ CALL LCMPUT(KPLIB,'PROB-TABLE',MAXNOR*NPART,2,SIGP)
+ DEALLOCATE(SIGP)
+ ENDIF
+ DO 15 IL=1,NL
+ ISM(1,IL)=ISMIN(IL,IGRP)
+ ISM(2,IL)=ISMAX(IL,IGRP)
+ 15 CONTINUE
+ CALL LCMPUT(KPLIB,'ISM-LIMITS',2*NL,1,ISM)
+ ELSE
+ IF(LCM) THEN
+ CALL LCMDRD(SIGP_PTR)
+ ELSE
+ DEALLOCATE(SIGP)
+ ENDIF
+ ENDIF
+ 20 CONTINUE
+ CALL LCMPUT(IPLIB,'NOR',NGRO,1,NOR)
+ CALL LCMSIX(IPLIB,' ',2)
+ ELSE IF(IPROC.EQ.2) THEN
+* BUILD A TEMPERATURE-INDEPENDENT DRAGLIB.
+ CALL LIBNOT(IPLIB,NGRO,NL,MDIL,NED,NDEL,IMPX,LSCAT,LSIGF,
+ 1 LADD,DILUT,FLUX,TOTAL,SIGF,SIGS,SCAT,SADD,ZDEL,HVECT)
+ ELSE IF((IPROC.EQ.3).OR.(IPROC.EQ.4).OR.(IPROC.EQ.5)) THEN
+* COMPUTE PHYSICAL PROBABILITY TABLES OR PROBABILITY TABLES
+* TAKING INTO ACCOUNT SLOWING-DOWN EFFECTS.
+*
+* RECOVER BIN TYPE INFORMATION (IF AVAILABLE).
+ LBSIGF=.FALSE.
+ CALL LCMLEN(IPLIB,'BIN-NFS',LENGT,ITYLCM)
+ LBIN=0
+ IF(LENGT.GT.0) THEN
+ CALL LCMGET(IPLIB,'BIN-NFS',NFS)
+ IGRMIN=1
+ IGRMAX=NGRO
+ DO 30 IGRP=NGRO,1,-1
+ IF((IGRMAX.EQ.IGRP).AND.(NFS(IGRP).EQ.0)) IGRMAX=IGRP-1
+ LBIN=LBIN+NFS(IGRP)
+ 30 CONTINUE
+ DO 40 IGRP=1,NGRO
+ IF((IGRMIN.EQ.IGRP).AND.(NFS(IGRP).EQ.0)) IGRMIN=IGRP+1
+ 40 CONTINUE
+ ALLOCATE(NBIN(NGRO),TBIN(LBIN),SBIN(LBIN),FBIN(LBIN),
+ 1 EBIN(LBIN+1))
+ CALL LCMGET(IPLIB,'BIN-ENERGY',EBIN)
+ CALL LCMGET(IPLIB,'BIN-NTOT0',TBIN)
+ CALL LCMGET(IPLIB,'BIN-SIGS00',SBIN)
+ CALL LCMLEN(IPLIB,'BIN-NUSIGF',LENGT,ITYLCM)
+ IF(LENGT.GT.0) THEN
+ CALL LCMGET(IPLIB,'BIN-NUSIGF',FBIN)
+ LBSIGF=.TRUE.
+ ENDIF
+ ELSE
+ NFS(:NGRO)=0
+ IGRMIN=1
+ IGRMAX=0
+ ENDIF
+*
+* RECOVER SCATTERING MATRIX PROFILE.
+ LPART=0
+ DO 55 IL=1,NL
+ DO 50 IG1=1,NGRO
+ LPART=MAX(LPART,ISMAX(IL,IG1)-ISMIN(IL,IG1)+1)
+ 50 CONTINUE
+ 55 CONTINUE
+*
+ CALL LIBFQD(MAXNPT,LPART,MAXTRA,HNAMIS,IPLIB,NGRO,NL,NED,
+ 1 NDEL,MDIL,IGRMIN,IGRMAX,LBIN,NFS,IMPX,LSCAT,LSIGF,LADD,
+ 2 DILUT,FLUX,TOTAL,SIGF,SIGS,SCAT,SADD,ZDEL,EBIN,TBIN,SBIN,
+ 3 FBIN,AWR,ISMIN,ISMAX,GOLD,IPRECI,NOR,LBSIGF)
+*
+ IF(LBIN.GT.0) THEN
+ DEALLOCATE(EBIN,SBIN,TBIN,NBIN)
+ IF(LBSIGF) DEALLOCATE(FBIN)
+ ENDIF
+ ELSE
+ CALL XABORT('LIBPTW: INVALID VALUE OF IPROC.')
+ ENDIF
+ DEALLOCATE(DELTG,ZDEL,SADD,SCAT,SIGS,SIGF,TOTAL,FLUX)
+ ELSE
+* DESTROY THE MULTI-DILUTION INTERNAL LIBRARY.
+ CALL LCMCL(IPTMP,2)
+ ENDIF
+*----
+* SCRATCH STORAGE DEALLOCATION
+*----
+ DEALLOCATE(GOLD)
+ DEALLOCATE(LADD,LSCAT)
+ DEALLOCATE(ISM,NOR,NFS,ISMAX,ISMIN)
+*
+ RETURN
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 11:33:54 +0000