From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001 From: stainer_t Date: Mon, 8 Sep 2025 13:48:49 +0200 Subject: Initial commit from Polytechnique Montreal --- Dragon/src/CPOMIC.f | 260 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 260 insertions(+) create mode 100644 Dragon/src/CPOMIC.f (limited to 'Dragon/src/CPOMIC.f') diff --git a/Dragon/src/CPOMIC.f b/Dragon/src/CPOMIC.f new file mode 100644 index 0000000..9bd25b6 --- /dev/null +++ b/Dragon/src/CPOMIC.f @@ -0,0 +1,260 @@ +*DECK CPOMIC + SUBROUTINE CPOMIC(IPCPO ,IPEDIT,IPRINT,NGROUP,NMERGE,NBMICR, + > NL ,IMRG ,ISOR ,NPROC ,ISOTMP,IDIMIX, + > INDPRO,ITYPRO,DENCPO,DENTMP,DXSMIC,DSCMIC, + > DMJCPO,DFLUX ) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compute microscopic cross sections for the Compo file. +* +*Copyright: +* Copyright (C) 2007 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): G. Marleau +* +*Parameters: input +* IPCPO pointer to the compo (L_COMPO signature). +* IPEDIT pointer to edit information (L_EDIT signature). +* IPRINT print parameter. Equal to zero for no print. +* NGROUP number of groups condensed . +* NMERGE number of regions merged. +* NBMICR maximum number of isotopes. +* NL number of Legendre orders. +* IMRG merge region indices. +* ISOR Compo isotope number. +* NPROC number of isotopes. +* ISOTMP name of isotopes in EDIT. +* IDIMIX isotopes identifier in each Compo material. +* INDPRO identifier for xs processing. +* ITYPRO identifier for xs processed. +* DENCPO Compo isotopes concentration. +* DENTMP Dragon isotopes concentration. +* +*Parameters: input/output +* DXSMIC micro vector xs. +* DSCMIC micro scat matrix xs. +* DFLUX flux. +* DMJCPO fission energy for macro. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPCPO,IPEDIT + INTEGER IPRINT,NGROUP,NMERGE,NBMICR,NL,IMRG,ISOR,NPROC, + > ISOTMP(3,NBMICR),IDIMIX(NMERGE,NBMICR), + > INDPRO(NPROC),ITYPRO(NPROC) + REAL DENTMP(NBMICR) + DOUBLE PRECISION DENCPO(NBMICR),DXSMIC(NGROUP,NPROC), + > DSCMIC(NGROUP,NGROUP,NL),DMJCPO(2,NBMICR), + > DFLUX(NGROUP) +*---- +* ALLOCATABLE ARRAYS +*---- + REAL, ALLOCATABLE, DIMENSION(:) :: HFACT + REAL, ALLOCATABLE, DIMENSION(:,:) :: XSREC + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: XSCAT + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* LOCAL PARAMETERS +*---- + INTEGER IOUT,NDPROC,IORD + PARAMETER (IOUT=6,NDPROC=20) + TYPE(C_PTR) KPEDIT + INTEGER NBISOE,ISOE,IADDXS,ITC,IXSR,JXSR,KXSR,IL, + > IGR,JGR,ILCMLN,ITYLCM + CHARACTER NAMISO*12 + DOUBLE PRECISION DSCPO,DNUFI,FACDEN,FACAXS +*---- +* SCRATCH STORAGE ALLOCATION +* XSREC fission energy for macro. +* XSCAT compress scattering. +*---- + ALLOCATE(XSREC(NGROUP,NPROC),XSCAT(NGROUP,NGROUP,NL), + > IPISO(NBMICR)) +*---- +* FIND ISOTOPE POINTERS IN INPUT MICROLIB +*---- + CALL LIBIPS(IPEDIT,NBMICR,IPISO) +*---- +* COMPUTE FINAL DENSITY OF ISOTOPE ISOR IN MIXTURE IMRG +*---- + NBISOE=0 + DO 100 ISOE=1,NBMICR + IF(IDIMIX(IMRG,ISOE).EQ.ISOR) THEN + NBISOE=NBISOE+1 + DENCPO(ISOR)=DENCPO(ISOR)+DENTMP(ISOE) + ENDIF + 100 CONTINUE + IF(DENCPO(ISOR).EQ.0.0D0) THEN + FACDEN=1.0D0/DBLE(NBISOE) + IADDXS=0 + ELSE + FACDEN=1.0D0/DENCPO(ISOR) + IADDXS=1 + ENDIF +*---- +* SCAN ALL ISOTOPES FOR THIS MERGE REGION AND +* LOCATE ADD XS FOR THOSE ASSOCIATED WITH ISOR +*---- + DSCPO=0.0D0 + DO 110 ISOE=1,NBMICR + IF(IDIMIX(IMRG,ISOE).EQ.ISOR) THEN + IF(IADDXS.EQ.0) THEN + FACAXS=FACDEN + ELSE + FACAXS=FACDEN*DBLE(DENTMP(ISOE)) + ENDIF +*---- +* READ MICRO XS +*---- + WRITE(NAMISO,'(3A4)') (ISOTMP(ITC,ISOE),ITC=1,3) + IF(IPRINT.GE.10) WRITE(IOUT,6000) NAMISO + KPEDIT=IPISO(ISOE) ! set ISOE-th isotope + IORD=1 + CALL XDRLGS(KPEDIT,-1,IPRINT,0,NL-1,IORD,NGROUP, + > XSREC(1,NDPROC+1),XSCAT,ITYPRO(NDPROC+1)) + CALL CPOLGX(KPEDIT,-1,IPRINT,IORD,NGROUP,INDPRO,XSREC(1,1), + > ITYPRO) +*---- +* ADD MICRO XS TO CPO ISOTOPE +*---- + DO 120 IXSR=1,4 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 121 IGR=1,NGROUP + DXSMIC(IGR,IXSR)=DXSMIC(IGR,IXSR) + > +FACAXS*DBLE(XSREC(IGR,IXSR)) + 121 CONTINUE + ENDIF + 120 CONTINUE + IXSR=4 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN +*---- +* COMPUTE TOTAL NEUTRON PRODUCED AND TOTAL ENERGY GENERATED +*---- + CALL LCMLEN(KPEDIT,'H-FACTOR',ILCMLN,ITYLCM) + IF(ILCMLN.EQ.NGROUP) THEN + ALLOCATE(HFACT(NGROUP)) + CALL LCMGET(KPEDIT,'H-FACTOR',HFACT) + DO 122 IGR=1,NGROUP + DMJCPO(1,ISOR)=DMJCPO(1,ISOR)+DENTMP(ISOE) + > *DFLUX(IGR)*DBLE(HFACT(IGR))*1.0E18 + DMJCPO(2,ISOR)=DMJCPO(2,ISOR)+DENTMP(ISOE) + > *DFLUX(IGR)*DBLE(XSREC(IGR,IXSR)) + 122 CONTINUE + DEALLOCATE(HFACT) + ENDIF + ENDIF + IXSR=5 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + JXSR=3 + DNUFI=0.0D0 + DO 130 IGR=1,NGROUP + DNUFI=DNUFI+DFLUX(IGR)*DBLE(XSREC(IGR,JXSR)) + 130 CONTINUE + DNUFI=DNUFI*FACAXS + DSCPO=DSCPO+DNUFI + DO 140 IGR=1,NGROUP + DXSMIC(IGR,IXSR)=DXSMIC(IGR,IXSR) + > +DNUFI*DBLE(XSREC(IGR,IXSR)) + 140 CONTINUE + ENDIF + DO 150 IXSR=7,NDPROC + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 151 IGR=1,NGROUP + DXSMIC(IGR,IXSR)=DXSMIC(IGR,IXSR) + > +FACAXS*DBLE(XSREC(IGR,IXSR)) + 151 CONTINUE + ENDIF + 150 CONTINUE + IL=0 + DO 160 IXSR=NDPROC+1,NDPROC+NL + IL=IL+1 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 170 IGR=1,NGROUP + DXSMIC(IGR,IXSR)=DXSMIC(IGR,IXSR) + > +FACAXS*DBLE(XSREC(IGR,IXSR)) + DO 171 JGR=1,NGROUP + DSCMIC(IGR,JGR,IL)=DSCMIC(IGR,JGR,IL) + > +FACAXS*DBLE(XSCAT(IGR,JGR,IL)) + 171 CONTINUE + 170 CONTINUE + ENDIF + 160 CONTINUE + ENDIF + 110 CONTINUE +*---- +* SAVE AVERAGE XS +*---- + XSREC(:NGROUP,:NPROC)=0.0 + XSCAT(:NGROUP,:NGROUP,:NL)=0.0 + DO 180 IXSR=1,4 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 181 IGR=1,NGROUP + XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,IXSR)) + 181 CONTINUE + ENDIF + 180 CONTINUE + IXSR=5 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + IF(DSCPO.NE.0.0D0) THEN + DO 190 IGR=1,NGROUP + XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,IXSR)/DSCPO) + 190 CONTINUE + ENDIF + ENDIF + IXSR=6 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + JXSR=4 + KXSR=3 + DO 191 IGR=1,NGROUP + IF(DXSMIC(IGR,JXSR).GT.0.0) THEN + XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,KXSR)/DXSMIC(IGR,JXSR)) + ENDIF + 191 CONTINUE + ENDIF + DO 200 IXSR=7,NDPROC + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 201 IGR=1,NGROUP + XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,IXSR)) + 201 CONTINUE + ENDIF + 200 CONTINUE + IL=0 + DO 210 IXSR=NDPROC+1,NDPROC+NL + IL=IL+1 + IF(INDPRO(IXSR).GT.0.AND.MOD(ITYPRO(IXSR),2).EQ.1) THEN + DO 220 IGR=1,NGROUP + XSREC(IGR,IXSR)=REAL(DXSMIC(IGR,IXSR)) + DO 221 JGR=1,NGROUP + XSCAT(IGR,JGR,IL)=REAL(DSCMIC(IGR,JGR,IL)) + 221 CONTINUE + 220 CONTINUE + ENDIF + 210 CONTINUE +*---- +* SAVE CPO MICRO +*---- + IORD=1 + CALL XDRLGS(IPCPO,1,IPRINT,0,NL-1,IORD,NGROUP,XSREC(1,NDPROC+1), + > XSCAT,ITYPRO(NDPROC+1)) + CALL CPOLGX(IPCPO,1,IPRINT,IORD,NGROUP,INDPRO,XSREC(1,1),ITYPRO) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPISO,XSCAT,XSREC) + RETURN +*---- +* PRINT FORMAT +*---- + 6000 FORMAT(' CPOMIC: INCLUDE ISOTOPE = ',A12) + END -- cgit v1.2.3