Initial commit from Polytechnique Montreal

1 files changed, 346 insertions, 0 deletions

diff --git a/Donjon/src/PCRONE.f b/Donjon/src/PCRONE.f
new file mode 100644
index 0000000..bb8aee2
--- /dev/null
+++ b/Donjon/src/PCRONE.f
@@ -0,0 +1,346 @@
+*DECK PCRONE
+      SUBROUTINE PCRONE(IMPX,ICAL,IPMIC,NCAL,NGRP,XS_CALC)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Copy an elementary calculation of the PMAXS file into a microlib.
+*
+*Copyright:
+* Copyright (C) 2019 Ecole Polytechnique de Montreal
+*
+*Author(s): 
+* A. Hebert and D. Calic
+*
+*Parameters: input
+* IMPX    print parameter.
+* ICAL    index of the elementary calculation.
+* IPMIC   address of the microlib.
+* NCAL    number of elementary calculations in the PMAXS file.
+* NGRP    number of energy groups.
+* XS_CALC pointers towards PMAXS elementary calculations.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      USE PCRDATA
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      INTEGER IMPX,ICAL,NCAL,NGRP
+      TYPE(C_PTR) IPMIC
+      TYPE(XSBLOCK_ITEM),TARGET :: XS_CALC(NCAL)
+*----
+*  LOCAL VARIABLES
+*----
+      TYPE(C_PTR) JPMIC,KPMIC
+      INTEGER NSTATE
+      PARAMETER(NSTATE=40)
+      INTEGER ISTATE(NSTATE),ITYPR(1)
+      REAL DENS(3)
+      DOUBLE PRECISION DELTA
+      LOGICAL LEX
+      CHARACTER(LEN=8) :: HVECT(3)
+      CHARACTER(LEN=12) :: HNAME,HISONA(3)
+      CHARACTER(LEN=131) :: HSMG
+      TYPE(XSBLOCK_TYPE),POINTER :: XSONE,XSREF
+      TYPE(TH_INDEP_VAR),POINTER :: TIVONE
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      REAL, ALLOCATABLE, DIMENSION(:) :: SIG1,GAR,ENERGY
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: SIG2
+*----
+*  SET SIGNATURE AND STATE VECTOR
+*----
+      INQUIRE(FILE='PCRONE.txt',EXIST=LEX)
+      IF(LEX) THEN
+        NUNIT=KDROPN('PCRONE.txt',1,3,0)
+      ELSE
+        NUNIT=KDROPN('PCRONE.txt',0,3,0)
+      ENDIF
+      IF(NUNIT.LE.0) THEN
+        WRITE(HSMG,'(28HPCRONE: KDROPN FAILURE (IER=,I5,2H).)') NUNIT
+        CALL XABORT(HSMG)
+      ENDIF
+
+      NED=1
+      HVECT(1)='H-FACTOR'
+      IF(NXST.GE.7) THEN
+         NED=2
+         HVECT(2)='NFTOT'
+      ENDIF
+      IF(NXST.EQ.8) THEN
+         NED=3
+         HVECT(3)='DETEC'
+      ENDIF
+      NBISO=1 ! number of isotopes
+      IF(NXST.GT.4) NBISO=3 ! include Xe and Sm
+      HNAME='L_LIBRARY'
+      CALL LCMPTC(IPMIC,'SIGNATURE',12,HNAME)
+      ISTATE(:)=0
+      ISTATE(1)=1
+      ISTATE(2)=NBISO
+      ISTATE(3)=NGRP
+      ISTATE(4)=1 ! isotropic scattering
+      ISTATE(13)=NED ! number of additional edits
+      ISTATE(19)=NDLAY ! number of delayed neutron groups
+      CALL LCMPUT(IPMIC,'STATE-VECTOR',NSTATE,1,ISTATE)
+      CALL LCMPTC(IPMIC,'ADDXSNAME-P0',8,NED,HVECT)
+      JPMIC=LCMLID(IPMIC,'ISOTOPESLIST',NBISO)
+*
+      ALLOCATE(SIG1(NGRP),SIG2(NGRP,NGRP))
+      XSONE=>XS_CALC(ICAL)%XS
+      XSREF=>XS_CALC(XS_CALC(ICAL)%IBURN)%XS
+      WRITE(NUNIT,*)XS_CALC(ICAL)%IBURN
+      TIVONE=>XS_CALC(ICAL)%TIV
+      KPMIC=LCMDIL(JPMIC,1) ! step up isot 1
+      HISONA(1)='*MAC*RES'
+      DENS(1)=1.0
+      CALL LCMPTC(KPMIC,'ALIAS',12,HISONA(1))
+*----
+*  PROCESS VECTORIAL CROSS SECTIONS
+*----
+*    1   2   3   4   5   6   7
+*   xtr,xab,xnf,xkf,xfi,xxe,xsm
+*----
+*  RUN ELEMENTARY CALC IN CASE THE PMAXS FILE IS GIVEN AS DERIVATIVES
+*----
+      IF(derivatives) THEN
+        DELTA=XS_CALC(ICAL)%DELTA
+        DO IG=1,NGRP
+          SIG1(IG)=REAL(XSREF%sig(IG,1)+DELTA*XSONE%sig(IG,1))
+        ENDDO
+        CALL LCMPUT(KPMIC,'STRD',NGRP,2,SIG1)
+        DO IG=1,NGRP
+          SIG1(IG)=REAL(XSREF%sig(IG,2)+SUM(XSREF%sct(IG,:))+DELTA*
+     1    XSONE%sig(IG,2)+SUM(XSONE%sct(IG,:)))
+        ENDDO
+        CALL LCMPUT(KPMIC,'NTOT0',NGRP,2,SIG1)
+        DO IG=1,NGRP
+          SIG1(IG)=REAL(XSREF%sig(IG,3)+DELTA*XSONE%sig(IG,3))
+          WRITE(NUNIT,*)SIG1(IG)
+        ENDDO
+        CALL LCMPUT(KPMIC,'NUSIGF',NGRP,2,SIG1)
+        DO IG=1,NGRP
+          SIG1(IG)=REAL(XSREF%sig(IG,4)+DELTA*XSONE%sig(IG,4))
+        ENDDO
+        CALL LCMPUT(KPMIC,'H-FACTOR',NGRP,2,SIG1)
+        IF(NXST.GT.4) THEN
+          DO IG=1,NGRP
+            SIG1(IG)=REAL(XSREF%sig(IG,7)+DELTA*XSONE%sig(IG,7))
+          ENDDO
+          CALL LCMPUT(KPMIC,'NFTOT',NGRP,2,SIG1)
+          SIG1(:NGRP)=0.0
+          SIG1(1)=1.0
+          CALL LCMPUT(KPMIC,'CHI',NGRP,2,SIG1)
+        ENDIF
+        IF(NXST.EQ.8) THEN
+          DO IG=1,NGRP
+            SIG1(IG)=REAL(XSREF%sig(IG,8)+DELTA*XSONE%sig(IG,8))
+          ENDDO
+          CALL LCMPUT(KPMIC,'DETEC',NGRP,2,SIG1)
+        ENDIF
+        IF(lamb) THEN
+          ALLOCATE(GAR(ELAM-BLAM+1))
+          GAR(:ELAM-BLAM+1)=REAL(TIVONE%kinp(BLAM:ELAM))
+          CALL LCMPUT(KPMIC,'LAMBDA',ELAM-BLAM+1,2,GAR)
+          DEALLOCATE(GAR)
+        ENDIF
+        DO j=1,iXSTI
+          k=iTIV(j)
+          IF(k.GT.0) THEN
+            DO IG=1,NGRP
+              SIG1(IG)=REAL(TIVONE%sig(IG,k))
+            ENDDO
+            IF(j.EQ.1) THEN
+              CALL LCMPUT(KPMIC,'CHI',NGRP,2,SIG1)
+            ELSE IF(j.EQ.2) THEN
+              CALL LCMPUT(KPMIC,'CHID',NGRP,2,SIG1)
+            ELSE IF(j.EQ.3) THEN
+              CALL LCMPUT(KPMIC,'INVEL',NGRP,2,SIG1)
+            ENDIF
+          ENDIF
+        ENDDO
+*----
+*  PROCESS SCATTERING INFORMATION (JG --> IG)
+*----
+        DO IG=1,NGRP
+          SIG1(IG)=REAL(SUM(XSREF%sct(IG,:))+DELTA*SUM(XSONE%sct(IG,:)))
+          DO JG=1,NGRP
+            SIG2(IG,JG)=REAL(XSREF%sct(JG,IG)+DELTA*XSONE%sct(JG,IG))
+          ENDDO
+        ENDDO
+        ITYPR(1)=1
+        CALL XDRLGS(KPMIC,1,IMPX,0,0,1,NGRP,SIG1,SIG2,ITYPR)
+        IF(IMPX.GT.5) CALL LCMLIB(KPMIC)
+*----
+*  PROCESS Xe and Sm
+*----
+        IF(NXST.GT.4) THEN
+          KPMIC=LCMDIL(JPMIC,2) ! step up isot 2
+          HISONA(2)='Xe135'
+          DENS(2)=0.0
+          CALL LCMPTC(KPMIC,'ALIAS',12,HISONA(2))
+          DO IG=1,NGRP
+            SIG1(IG)=REAL(XSREF%sig(IG,5)+DELTA*XSONE%sig(IG,5))
+          ENDDO
+          CALL LCMPUT(KPMIC,'NTOT0',NGRP,2,SIG1)
+          CALL LCMPUT(KPMIC,'STRD',NGRP,2,SIG1)
+          DO IG=1,NGRP
+            SIG1(IG)=0.0
+            DO JG=1,NGRP
+              SIG2(IG,JG)=0.0
+            ENDDO
+          ENDDO
+          ITYPR(1)=1
+          CALL XDRLGS(KPMIC,1,IMPX,0,0,1,NGRP,SIG1,SIG2,ITYPR)
+          KPMIC=LCMDIL(JPMIC,3) ! step up isot 3
+          HISONA(3)='Sm149'
+          DENS(3)=0.0
+          CALL LCMPTC(KPMIC,'ALIAS',12,HISONA(3))
+          DO IG=1,NGRP
+            SIG1(IG)=REAL(XSREF%sig(IG,6)+DELTA*XSONE%sig(IG,6))
+          ENDDO
+          CALL LCMPUT(KPMIC,'NTOT0',NGRP,2,SIG1)
+          CALL LCMPUT(KPMIC,'STRD',NGRP,2,SIG1)
+          DO IG=1,NGRP
+            SIG1(IG)=0.0
+            DO JG=1,NGRP
+              SIG2(IG,JG)=0.0
+            ENDDO
+          ENDDO
+          ITYPR(1)=1
+          CALL XDRLGS(KPMIC,1,IMPX,0,0,1,NGRP,SIG1,SIG2,ITYPR)
+        ENDIF
+        CALL LCMPTC(IPMIC,'ISOTOPESUSED',12,NBISO,HISONA)
+        CALL LCMPUT(IPMIC,'ISOTOPESDENS',NBISO,2,DENS)
+        DEALLOCATE(SIG2,SIG1)
+      ELSE
+*----
+*  RUN ELEMENTARY CALC IN CASE THE PMAXS FILE IS GIVEN AS RAW CROSS
+*  SECTIONS
+*----
+        DELTA=XS_CALC(ICAL)%DELTA
+        DO IG=1,NGRP
+          SIG1(IG)=REAL(XSONE%sig(IG,1))
+        ENDDO
+        CALL LCMPUT(KPMIC,'STRD',NGRP,2,SIG1)
+        DO IG=1,NGRP
+          SIG1(IG)=REAL(XSONE%sig(IG,2)+SUM(XSONE%sct(IG,:)))
+        ENDDO
+        CALL LCMPUT(KPMIC,'NTOT0',NGRP,2,SIG1)
+        DO IG=1,NGRP
+          SIG1(IG)=REAL(XSONE%sig(IG,3))
+          WRITE(NUNIT,*)XSONE%sig(IG,3)
+        ENDDO
+        CALL LCMPUT(KPMIC,'NUSIGF',NGRP,2,SIG1)
+        DO IG=1,NGRP
+          SIG1(IG)=REAL(XSONE%sig(IG,4))
+        ENDDO
+        CALL LCMPUT(KPMIC,'H-FACTOR',NGRP,2,SIG1)
+        IF(NXST.GT.4) THEN
+          DO IG=1,NGRP
+            SIG1(IG)=REAL(XSONE%sig(IG,7))
+          ENDDO
+          CALL LCMPUT(KPMIC,'NFTOT',NGRP,2,SIG1)
+          SIG1(:NGRP)=0.0
+          SIG1(1)=1.0
+          CALL LCMPUT(KPMIC,'CHI',NGRP,2,SIG1)
+        ENDIF
+        IF(NXST.EQ.8) THEN
+          DO IG=1,NGRP
+            SIG1(IG)=REAL(XSONE%sig(IG,8))
+          ENDDO
+          CALL LCMPUT(KPMIC,'DETEC',NGRP,2,SIG1)
+        ENDIF
+        IF(lamb) THEN
+          ALLOCATE(GAR(ELAM-BLAM+1))
+          GAR(:ELAM-BLAM+1)=REAL(TIVONE%kinp(BLAM:ELAM))
+          CALL LCMPUT(KPMIC,'LAMBDA',ELAM-BLAM+1,2,GAR)
+          DEALLOCATE(GAR)
+        ENDIF
+        DO j=1,iXSTI
+          k=iTIV(j)
+          IF(k.GT.0) THEN
+            DO IG=1,NGRP
+              SIG1(IG)=REAL(TIVONE%sig(IG,k))
+            ENDDO
+            IF(j.EQ.1) THEN
+              CALL LCMPUT(KPMIC,'CHI',NGRP,2,SIG1)
+            ELSE IF(j.EQ.2) THEN
+              CALL LCMPUT(KPMIC,'CHID',NGRP,2,SIG1)
+            ELSE IF(j.EQ.3) THEN
+              CALL LCMPUT(KPMIC,'INVEL',NGRP,2,SIG1)
+            ENDIF
+          ENDIF
+        ENDDO
+*----
+*  PROCESS SCATTERING INFORMATION
+*----
+        DO IG=1,NGRP
+           SIG1(IG)=REAL(SUM(XSONE%sct(IG,:)))
+          DO JG=1,NGRP
+            SIG2(IG,JG)=REAL(XSONE%sct(JG,IG)) ! JG --> IG
+          ENDDO
+        ENDDO
+        ITYPR(1)=1
+        CALL XDRLGS(KPMIC,1,IMPX,0,0,1,NGRP,SIG1,SIG2,ITYPR)
+        IF(IMPX.GT.5) CALL LCMLIB(KPMIC)
+*----
+*  PROCESS Xe and Sm
+*----
+        IF(NXST.GT.4) THEN
+          KPMIC=LCMDIL(JPMIC,2) ! step up isot 2
+          HISONA(2)='Xe135'
+          DENS(2)=0.0
+          CALL LCMPTC(KPMIC,'ALIAS',12,HISONA(2))
+          DO IG=1,NGRP
+            SIG1(IG)=REAL(XSONE%sig(IG,5))
+          ENDDO
+          CALL LCMPUT(KPMIC,'NTOT0',NGRP,2,SIG1)
+          CALL LCMPUT(KPMIC,'STRD',NGRP,2,SIG1)
+          DO IG=1,NGRP
+            SIG1(IG)=0.0
+            DO JG=1,NGRP
+              SIG2(IG,JG)=0.0
+            ENDDO
+          ENDDO
+          ITYPR(1)=1
+          CALL XDRLGS(KPMIC,1,IMPX,0,0,1,NGRP,SIG1,SIG2,ITYPR)
+          KPMIC=LCMDIL(JPMIC,3) ! step up isot 3
+          HISONA(3)='Sm149'
+          DENS(3)=0.0
+          CALL LCMPTC(KPMIC,'ALIAS',12,HISONA(3))
+          DO IG=1,NGRP
+            SIG1(IG)=REAL(XSONE%sig(IG,6))
+          ENDDO
+          CALL LCMPUT(KPMIC,'NTOT0',NGRP,2,SIG1)
+          CALL LCMPUT(KPMIC,'STRD',NGRP,2,SIG1)
+          DO IG=1,NGRP
+            SIG1(IG)=0.0
+            DO JG=1,NGRP
+              SIG2(IG,JG)=0.0
+            ENDDO
+          ENDDO
+          ITYPR(1)=1
+          CALL XDRLGS(KPMIC,1,IMPX,0,0,1,NGRP,SIG1,SIG2,ITYPR)
+        ENDIF
+        CALL LCMPTC(IPMIC,'ISOTOPESUSED',12,NBISO,HISONA)
+        CALL LCMPUT(IPMIC,'ISOTOPESDENS',NBISO,2,DENS)
+        DEALLOCATE(SIG2,SIG1)
+      ENDIF
+      CLOSE(NUNIT)
+*----
+*  SET ENERGY MESH
+*----
+      ALLOCATE(ENERGY(NGRP+1))
+      IF(NGRP.EQ.2) THEN
+        ENERGY(:)=(/ 1.964E7,  6.25E-1,  1.1E-4 /)
+      ELSE
+        CALL XABORT('PCRONE: UNKNOWN ENERGY MESH')
+      ENDIF
+      CALL LCMPUT(IPMIC,'ENERGY',NGRP+1,2,ENERGY)
+      DEALLOCATE(ENERGY)
+      RETURN
+      END