summaryrefslogtreecommitdiff
path: root/Donjon/src/D2PPRC.f
diff options
context:
space:
mode:
Diffstat (limited to 'Donjon/src/D2PPRC.f')
-rw-r--r--Donjon/src/D2PPRC.f290
1 files changed, 290 insertions, 0 deletions
diff --git a/Donjon/src/D2PPRC.f b/Donjon/src/D2PPRC.f
new file mode 100644
index 0000000..1e989bb
--- /dev/null
+++ b/Donjon/src/D2PPRC.f
@@ -0,0 +1,290 @@
+ SUBROUTINE D2PPRC ( IPDAT,IPPRC, HEQUI, HMASL, ISOTVAL, ISOTOPT,
+ > LMEM,IPRINT,MIXDIR,JOBOPT )
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Build a procedure file for the interpolation of cross sections
+*
+*Author(s):
+* J. Taforeau
+*
+*Parameters: input
+* IPDAT adress of info data block
+* HEQUI name of the equivalence record in the saphyb|MCO object
+* HMASL name of heavy metal density record in the saphyb|MCO object
+* ISOTVAL concentration of particularized isotopes
+* ISOTOPT otpion for paticularised isotopes
+*
+*Parameters:
+* IPPRC
+* LMEM
+* IPRINT
+* MIXDIR
+* JOBOPT
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ TYPE(C_PTR) IPDAT,IPTH,KPTH
+ INTEGER IPPRC,PK,IPRINT
+ CHARACTER*4 HEQUI,HMASL
+ CHARACTER*1 ISOTOPT,JOBOPT(14)
+ CHARACTER*12,ISOTOPES(8)
+ REAL ISOTVAL
+ LOGICAL LMEM,LFLAG(6)
+*----
+* LOCAL VARIABLES
+*----
+ CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: PKEY
+ CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: OTHPK
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: OTHTYP
+ CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: OTHVAC
+ REAL, ALLOCATABLE, DIMENSION(:) :: OTHVAR
+ CHARACTER*12 PKNAM(6),MIXDIR
+ INTEGER STAVEC(40),NVAR,ITYP,NOTH
+ INTEGER :: NTOT = 0
+ INTEGER :: NPKEY = 0
+ INTEGER :: ORDER(6) = -1
+ CHARACTER*6 :: NAMSAP='XSLIB'
+ CHARACTER*4,DIMENSION(6) :: REFNAM
+ DATA REFNAM/ "BARR","DMOD","CBOR","TCOM","TMOD","BURN"/
+
+ WRITE(IPPRC,*)'!************************************************'
+ WRITE(IPPRC,*)'! Auto Generation of input file for D2P *'
+ WRITE(IPPRC,*)'! - Recovering of information from D2P PHASE 1 *'
+ WRITE(IPPRC,*)'! - call to the interpolation module(SCR|NCR) *'
+ WRITE(IPPRC,*)'! - call of D2P for PHASE 2 and 3 *'
+ WRITE(IPPRC,*)'! Author(s) : J. TAFOREAU (2016) *'
+ WRITE(IPPRC,*)'!************************************************'
+ WRITE(IPPRC,*)
+
+ WRITE(IPPRC,*)" SEQ_ASCII GENPMAXS :: FILE 'GENPMAXS.inp' ; "
+ WRITE(IPPRC,*)" SEQ_ASCII HELIOS :: FILE 'HELIOS.dra' ; "
+ WRITE(IPPRC,*)" XSM_FILE XSLIB :: FILE 'XSLIB' ; "
+ WRITE(IPPRC,*)" XSM_FILE D2PINFO :: FILE 'Info.xsm' ; "
+ WRITE(IPPRC,*)" LINKED_LIST INFO ; "
+ IF (LMEM) THEN
+ WRITE(IPPRC,*)'LINKED_LIST XSL ; '
+ NAMSAP='XSL'
+ ENDIF
+
+ WRITE(IPPRC,*)'LINKED_LIST Micro ; '
+ WRITE(IPPRC,*)'MODULE END: D2P: SCR: NCR: GREP: DELETE: UTL: ;'
+ WRITE(IPPRC,*)
+ WRITE(IPPRC,*)'!************************************************'
+ WRITE(IPPRC,*)'! STEP 0 : Initializing state parameters *'
+ WRITE(IPPRC,*)'!************************************************'
+ WRITE(IPPRC,*)
+
+ CALL LCMGET(IPDAT,'STATE-VECTOR',STAVEC)
+ NVAR=STAVEC(2)
+ ITYP=STAVEC(18)
+ NOTH=STAVEC(20)
+ ALLOCATE(PKEY(NVAR))
+ ALLOCATE(OTHPK(NOTH),OTHTYP(NOTH),OTHVAC(NOTH),OTHVAR(NOTH))
+ CALL LCMSIX(IPDAT,'SAPHYB_INFO',1)
+ CALL LCMGTC(IPDAT,'ISOTOPES',12,4,ISOTOPES)
+ CALL LCMGTC(IPDAT,'STATE_VAR',12,NVAR,PKEY)
+ CALL LCMGET(IPDAT,'NTOT',NTOT)
+ IF (NOTH>0) THEN
+ CALL LCMGTC(IPDAT,'OTHPK',12,NOTH,OTHPK)
+ CALL LCMGET(IPDAT,'OTHTYP',OTHTYP)
+ CALL LCMGTC(IPDAT,'OTHVAC',12,NOTH,OTHVAC)
+ CALL LCMGET(IPDAT,'OTHVAR',OTHVAR)
+ ENDIF
+
+ DO PK=1, 6
+ IPTH=LCMGID(IPDAT,'PKEY_INFO')
+ KPTH=LCMDIL(IPTH,PK)
+ CALL LCMGET(KPTH,'LFLAG',LFLAG(PK))
+ IF(LFLAG(PK)) THEN
+ NPKEY=NPKEY+1
+ CALL LCMGTC(KPTH,'NAME',12,PKNAM(PK))
+ CALL LCMGTC(KPTH,'NAME',12,PKNAM(PK))
+ WRITE(IPPRC,*) 'STRING ',
+ > REFNAM(PK),' := "',TRIM(PKNAM(PK)),'" ; '
+ WRITE(IPPRC,*) 'REAL ',REFNAM(PK),'_VAL ; '
+ DO I=1,NVAR
+ IF (PKNAM(PK).EQ.PKEY(I)) THEN
+ ORDER(PK)=I
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+
+ IF (NTOT.NE.(NOTH+NPKEY)) THEN
+ WRITE(6,*) "@D2PPROC: INCONSISTENT D2P INPUT DATA WITH",
+ > "XS LIBRARY"
+ WRITE(6,*) "D2P INPUT DATA : "
+ WRITE(6,*) " STATE VARIABLE : ", NPKEY
+ WRITE(6,*) " OTHER VARIABLE : ", NOTH
+ WRITE(6,*) "D2P TOTAL = ", NPKEY+NOTH
+ WRITE(6,*) "XS LIBRARY CONTENT = ", NTOT
+ CALL XABORT ("=>PLEASE USE THE D2P CARD 'PKEY'AND/OR 'OTHER'")
+ ENDIF
+
+ IF (NPKEY .EQ. 0) THEN
+ WRITE(6,*) "@D2PPROC : NUMBER OF STATE VARIABLES IS ZERO"
+ CALL XABORT ("=> PLEASE CHECK THE D2P DATA INPUT ")
+ ENDIF
+ WRITE(IPPRC,*)'INFO := D2PINFO ; '
+ IF (LMEM) WRITE(IPPRC,*)'XSL := XSLIB ;'
+ WRITE(IPPRC,*)'INTEGER NVAR := ',NPKEY,' ; '
+ WRITE(IPPRC,*)'INTEGER STOP REWIND ITER := 0 0 0 ; '
+
+ WRITE(IPPRC,*)
+ WRITE(IPPRC,*)'WHILE STOP 1 <> DO'
+
+ WRITE(IPPRC,*)
+ WRITE(IPPRC,*)'!************************************************'
+ WRITE(IPPRC,*)'! STEP 1 : recovering state parameters *'
+ WRITE(IPPRC,*)'!************************************************'
+ WRITE(IPPRC,*)
+
+ DO PK=1, 6
+ IF (LFLAG(PK)) THEN
+ WRITE(IPPRC,*) "GREP: INFO :: STEP UP 'BRANCH_INFO'"
+ WRITE(IPPRC,*) "GETVAL STATE ",ORDER(PK)," NVAL 1 >>",
+ > REFNAM(PK),"_VAL<< ;"
+ ENDIF
+ ENDDO
+
+ WRITE(IPPRC,*)
+ WRITE(IPPRC,*)'!************************************************'
+ WRITE(IPPRC,*)'! STEP 2 : interpolation of cross sections *'
+ WRITE(IPPRC,*)'! warning => check the isotopes names *'
+ WRITE(IPPRC,*)'!************************************************'
+ WRITE(IPPRC,*)
+
+ WRITE(IPPRC,*)'EVALUATE ITER := ITER 1 + ;'
+ IF (ITYP.EQ.0) WRITE(IPPRC,*)' Micro := SCR: ',NAMSAP,' ::'
+ IF (ITYP.EQ.1) WRITE(IPPRC,*)' Micro := NCR: ',NAMSAP,' ::'
+ WRITE(IPPRC,*)' EDIT ',IPRINT
+ IF (ITYP.EQ.0) THEN
+ IF (HEQUI.NE.'NONE') WRITE(IPPRC,*)' EQUI ',HEQUI
+ IF (HMASL.NE.'NONE') WRITE(IPPRC,*)' MASL ',HMASL
+ ENDIF
+
+ WRITE(IPPRC,*)' MICRO LINEAR NMIX 1'
+ IF (ITYP.EQ.0)WRITE(IPPRC,*)' SAPHYB ',NAMSAP
+ IF (ITYP.EQ.1)WRITE(IPPRC,*)' COMPO ',NAMSAP,' ',
+ > TRIM(MIXDIR)
+
+ WRITE(IPPRC,*)' MIX 1'
+ DO IOTH=1,NOTH
+ WRITE(IPPRC,'(A,A)',advance='no')' SET LINEAR ',
+ > TRIM(OTHPK(IOTH))
+ SELECT CASE (OTHTYP(IOTH))
+ CASE (1)
+ WRITE(IPPRC,*) ' ',INT(OTHVAR(IOTH))
+ CASE (2)
+ WRITE(IPPRC,*) ' ',OTHVAR(IOTH)
+ CASE (3)
+ WRITE(IPPRC,*) " '", TRIM(OTHVAC(IOTH)),"'"
+ END SELECT
+ ENDDO
+ DO PK=1,6
+ IF (LFLAG(PK)) THEN
+ WRITE(IPPRC,*)' SET LINEAR <<',REFNAM(PK),'>> <<',
+ > REFNAM(PK),'_VAL>>'
+ ENDIF
+ ENDDO
+
+ IF (JOBOPT(2).EQ.'T') THEN
+ CALL LCMSIX(IPDAT,'',0)
+ CALL LCMSIX(IPDAT,'SAPHYB_INFO',1)
+ CALL LCMSIX(IPDAT,'ISOTOPES',1)
+ CALL LCMGTC(IPDAT,'XE135',12,ISOTOPES(1))
+ CALL LCMGTC(IPDAT,'I135',12,ISOTOPES(2))
+ CALL LCMGTC(IPDAT,'SM149',12,ISOTOPES(3))
+ CALL LCMGTC(IPDAT,'PM149',12,ISOTOPES(4))
+ CALL LCMGTC(IPDAT,'PM148',12,ISOTOPES(5))
+ CALL LCMGTC(IPDAT,'PM148M',12,ISOTOPES(6))
+ CALL LCMGTC(IPDAT,'ND147',12,ISOTOPES(7))
+ CALL LCMGTC(IPDAT,'PM147',12,ISOTOPES(8))
+ WRITE(IPPRC,*)' MICRO ALL'
+
+ DO I=1,8
+ SELECT CASE (ISOTOPT)
+ CASE ('*')
+ WRITE(IPPRC,*)" '",TRIM(ISOTOPES(I)),"' *"
+ CASE DEFAULT
+ IF ((I.EQ.1).OR.(I.EQ.3).OR.(I.EQ.8)) THEN
+ WRITE(IPPRC,*)" '",TRIM(ISOTOPES(I)),"' *"
+ ELSE
+ WRITE(IPPRC,*)" '",TRIM(ISOTOPES(I)),"'",ISOTVAL
+ ENDIF
+ END SELECT
+ ENDDO
+ ENDIF
+ WRITE(IPPRC,*)' ENDMIX'
+
+ IF ((JOBOPT(9).EQ.'T').AND.(ITYP.EQ.0) ) THEN
+ WRITE(IPPRC,*)" CHAIN"
+ WRITE(IPPRC,*)" ",TRIM(ISOTOPES(2))," NG 0.0"
+ WRITE(IPPRC,*)" ",TRIM(ISOTOPES(7))," NG 0.0"
+ WRITE(IPPRC,*)" ",TRIM(ISOTOPES(1)),
+ > " NG 0.0 FROM DECAY 1.0E+00 ",TRIM(ISOTOPES(2))
+ WRITE(IPPRC,*)" ",TRIM(ISOTOPES(8)),
+ > " NG 0.0 FROM DECAY 1.0E+00 ",TRIM(ISOTOPES(7))
+ WRITE(IPPRC,*)" ",TRIM(ISOTOPES(5)),
+ > " NG 0.0 FROM NG 5.3E-01 ",TRIM(ISOTOPES(8))
+ WRITE(IPPRC,*)" ",TRIM(ISOTOPES(6)),
+ > " NG 0.0 FROM NG 4.7E-01 ",TRIM(ISOTOPES(8))
+ WRITE(IPPRC,*)" ",TRIM(ISOTOPES(4)),
+ > " NG 0.0 FROM NG 1.0E+00 ",TRIM(ISOTOPES(5)),
+ > " NG 1.0E+00 ",TRIM(ISOTOPES(6))
+ WRITE(IPPRC,*)" ",TRIM(ISOTOPES(3)),
+ > " NG 0.0 FROM DECAY 1.0E+00 ",TRIM(ISOTOPES(4))
+ WRITE(IPPRC,*)" MACR NFTOT 0.0"
+ WRITE(IPPRC,*)" ENDCHAIN"
+ ENDIF
+ WRITE(IPPRC,*)' ;'
+ WRITE(IPPRC,*)
+ WRITE(IPPRC,*)'!************************************************'
+ WRITE(IPPRC,*)'! STEP 3 : branching calculation *'
+ WRITE(IPPRC,*)'!************************************************'
+ WRITE(IPPRC,*)
+ WRITE(IPPRC,*)"IF ITER 1 = THEN "
+ WRITE(IPPRC,*)"HELIOS GENPMAXS INFO Micro := D2P: "
+ WRITE(IPPRC,*)"Micro INFO ",
+ > NAMSAP," ::"
+ WRITE(IPPRC,*)"PHASE 2 EDIT",IPRINT,";"
+ WRITE(IPPRC,*)"ELSE"
+ WRITE(IPPRC,*)"HELIOS GENPMAXS INFO Micro := D2P: "
+ WRITE(IPPRC,*)"Micro INFO GENPMAXS ",
+ > NAMSAP," HELIOS ::"
+ WRITE(IPPRC,*)"PHASE 2 EDIT",IPRINT,";"
+ WRITE(IPPRC,*)
+ WRITE(IPPRC,*)"ENDIF ;"
+ WRITE(IPPRC,*)"Micro := DELETE: Micro ;"
+ WRITE(IPPRC,*)
+ WRITE(IPPRC,*)"GREP: INFO :: STEP UP 'BRANCH_INFO'"
+ WRITE(IPPRC,*)"GETVAL REWIND 1 NVAL 1 >>REWIND<< ;"
+
+ WRITE(IPPRC,*)'!************************************************'
+ WRITE(IPPRC,*)'! STEP 4 : storing the current branch *'
+ WRITE(IPPRC,*)'!************************************************'
+ WRITE(IPPRC,*)
+ WRITE(IPPRC,*)"IF REWIND 1 = THEN"
+ WRITE(IPPRC,*)
+ WRITE(IPPRC,*)" HELIOS GENPMAXS INFO := D2P: INFO "
+ WRITE(IPPRC,*)" GENPMAXS HELIOS ::"
+ WRITE(IPPRC,*)" PHASE 3 EDIT",IPRINT," ;"
+
+ WRITE(IPPRC,*)" GREP: INFO :: STEP UP 'BRANCH_INFO'"
+ WRITE(IPPRC,*)" GETVAL STOP 1 NVAL 1 >>STOP<< ;"
+
+ WRITE(IPPRC,*)"ENDIF ;"
+ WRITE(IPPRC,*)
+ WRITE(IPPRC,*)"ENDWHILE ;"
+ WRITE(IPPRC,*)
+ WRITE(IPPRC,*)"END: ;"
+ WRITE(IPPRC,*)"QUIT ."
+ DEALLOCATE(PKEY)
+ DEALLOCATE(OTHPK,OTHTYP,OTHVAC,OTHVAR)
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 14:49:58 +0000