diff options
Diffstat (limited to 'Dragon/src/TRAGRO.f')
| -rw-r--r-- | Dragon/src/TRAGRO.f | 209 |
1 files changed, 209 insertions, 0 deletions
diff --git a/Dragon/src/TRAGRO.f b/Dragon/src/TRAGRO.f new file mode 100644 index 0000000..09bda37 --- /dev/null +++ b/Dragon/src/TRAGRO.f @@ -0,0 +1,209 @@ +*DECK TRAGRO + SUBROUTINE TRAGRO(IPMAC1,IPMAC2,NG,NMIL,NL,NF,NDEL) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Transposition of information in GROUP list. +* +*Copyright: +* Copyright (C) 2008 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 +* IPMAC1 pointer to the transposed macrolib. +* IPMAC2 pointer to the original macrolib. +* NG number of energy groups. +* NMIL number of homogenized mixtures. +* NL number of Legendre orders. +* NF number of fissile isotopes. +* NDEL number of precursor groups. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMAC1,IPMAC2 + INTEGER NG,NMIL,NL,NF,NDEL +*---- +* LOCAL VARIABLES +*---- + TYPE(C_PTR) JPMAC1,KPMAC1,JPMAC2,KPMAC2 + CHARACTER CM*2,NAMT1*12,NAMT2*12,TEXT12*12 + DOUBLE PRECISION SUMA,SUMB +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS + REAL, ALLOCATABLE, DIMENSION(:) :: GAR3,XIOF,VOLMER + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: GAR1A,GAR1B,GAR2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(IJJ(NMIL),NJJ(NMIL),IPOS(NMIL)) + ALLOCATE(GAR1A(NMIL,NF,NG),GAR1B(NMIL,NF,NG),GAR2(NG,NG,NMIL), + 1 GAR3(NMIL*NG)) +*---- +* PROCESS TRANSFERT SCATTERING INFORMATION +*---- + JPMAC2=LCMGID(IPMAC2,'GROUP') + JPMAC1=LCMLID(IPMAC1,'GROUP',NG) + DO IL=1,NL + WRITE(CM,'(I2.2)') IL-1 + GAR2(:NG,:NG,:NMIL)=0.0 + DO IG=1,NG + KPMAC2=LCMGIL(JPMAC2,IG) + LENGTH=1 + IF(IL.GT.1) CALL LCMLEN(KPMAC2,'SCAT'//CM,LENGTH,ITYLCM) + IF(LENGTH.GT.0) THEN + CALL LCMGET(KPMAC2,'SCAT'//CM,GAR3) + CALL LCMGET(KPMAC2,'NJJS'//CM,NJJ) + CALL LCMGET(KPMAC2,'IJJS'//CM,IJJ) + CALL LCMGET(KPMAC2,'IPOS'//CM,IPOS) + DO IMIL=1,NMIL + IPOSDE=IPOS(IMIL) + DO JG=IJJ(IMIL),IJJ(IMIL)-NJJ(IMIL)+1,-1 + GAR2(IG,JG,IMIL)=GAR3(IPOSDE) ! IG <-- JG + IPOSDE=IPOSDE+1 + ENDDO + ENDDO + ENDIF + ENDDO + DO IG=1,NG + KPMAC1=LCMDIL(JPMAC1,IG) + IPOSDE=0 + DO IMIL=1,NMIL + IPOS(IMIL)=IPOSDE+1 + IGMIN=IG + IGMAX=IG + DO JG=1,NG + IF(GAR2(NG-JG+1,NG-IG+1,IMIL).NE.0.0) THEN + IGMIN=MIN(IGMIN,JG) + IGMAX=MAX(IGMAX,JG) + ENDIF + ENDDO + IJJ(IMIL)=IGMAX + NJJ(IMIL)=IGMAX-IGMIN+1 + DO JG=IGMAX,IGMIN,-1 + IPOSDE=IPOSDE+1 + GAR3(IPOSDE)=GAR2(NG-JG+1,NG-IG+1,IMIL) + ENDDO + ENDDO + IF(IPOSDE.GT.0) THEN + CALL LCMPUT(KPMAC1,'SCAT'//CM,IPOSDE,2,GAR3) + CALL LCMPUT(KPMAC1,'NJJS'//CM,NMIL,1,NJJ) + CALL LCMPUT(KPMAC1,'IJJS'//CM,NMIL,1,IJJ) + CALL LCMPUT(KPMAC1,'IPOS'//CM,NMIL,1,IPOS) + ENDIF + ENDDO + ENDDO +*---- +* PROCESS VECTOR CROSS SECTIONS +*---- + ALLOCATE(VOLMER(NMIL)) + CALL LCMLEN(IPMAC2,'VOLUME',ILONG,ITYLCM) + IF(ILONG.EQ.NMIL) CALL LCMGET(IPMAC2,'VOLUME',VOLMER) + DO IG=1,NG + KPMAC2=LCMGIL(JPMAC2,IG) + KPMAC1=LCMDIL(JPMAC1,NG-IG+1) + NAMT2=' ' + CALL LCMNXT(KPMAC2,NAMT2) + TEXT12=NAMT2 + 10 IF(NAMT2(:4).EQ.'SCAT') GO TO 20 + IF(NAMT2(:4).EQ.'NJJS') GO TO 20 + IF(NAMT2(:4).EQ.'IJJS') GO TO 20 + IF(NAMT2(:4).EQ.'IPOS') GO TO 20 + CALL LCMLEN(KPMAC2,NAMT2,ILONG,ITYLCM) + IF(ILONG.GT.0) THEN + ALLOCATE(XIOF(ILONG)) + CALL LCMGET(KPMAC2,NAMT2,XIOF) + NAMT1=NAMT2 + IF(NAMT2(:3).EQ.'CHI') THEN + NAMT1='NUSIGF'//NAMT2(4:) + ELSE IF(NAMT2(:6).EQ.'NUSIGF') THEN + NAMT1='CHI'//NAMT2(7:) + ELSE IF(NAMT2(:9).EQ.'FLUX-INTG') THEN + NAMT1='NWAT0' + DO IMIL=1,NMIL + XIOF(IMIL)=XIOF(IMIL)/VOLMER(IMIL) + ENDDO + ELSE IF(NAMT2.EQ.'FLUX-INTG-P1') THEN + NAMT1='NWAT1' + DO IMIL=1,NMIL + XIOF(IMIL)=XIOF(IMIL)/VOLMER(IMIL) + ENDDO + ELSE IF(NAMT2(:5).EQ.'NWAT0') THEN + NAMT1='FLUX-INTG' + DO IMIL=1,NMIL + XIOF(IMIL)=XIOF(IMIL)*VOLMER(IMIL) + ENDDO + ELSE IF(NAMT2(:5).EQ.'NWAT1') THEN + NAMT1='FLUX-INTG-P1' + DO IMIL=1,NMIL + XIOF(IMIL)=XIOF(IMIL)*VOLMER(IMIL) + ENDDO + ENDIF + CALL LCMPUT(KPMAC1,NAMT1,ILONG,2,XIOF) + DEALLOCATE(XIOF) + ENDIF + 20 CALL LCMNXT(KPMAC2,NAMT2) + IF(NAMT2.NE.TEXT12) GO TO 10 + ENDDO + DEALLOCATE(VOLMER) +*---- +* FISSION SPECTRUM NORMALIZATION +*---- + DO IDEL=0,NDEL + IF(IDEL.EQ.0) THEN + CM=' ' + ELSE + WRITE(CM,'(I2.2)') IDEL + ENDIF + GAR1A(:NMIL,:NF,:NG)=0.0 + GAR1B(:NMIL,:NF,:NG)=0.0 + DO IG=1,NG + KPMAC1=LCMGIL(JPMAC1,IG) + CALL LCMGET(KPMAC1,'CHI'//CM,GAR1A(1,1,IG)) + CALL LCMGET(KPMAC1,'NUSIGF'//CM,GAR1B(1,1,IG)) + ENDDO + DO IFIS=1,NF + DO IMIL=1,NMIL + SUMA=0.0D0 + SUMB=0.0D0 + DO IG=1,NG + SUMA=SUMA+GAR1A(IMIL,IFIS,IG) + SUMB=SUMB+GAR1B(IMIL,IFIS,IG) + ENDDO + IF(SUMA.GT.0.0) THEN + DO IG=1,NG + GAR1A(IMIL,IFIS,IG)=GAR1A(IMIL,IFIS,IG)*REAL(SUMB/SUMA) + GAR1B(IMIL,IFIS,IG)=GAR1B(IMIL,IFIS,IG)*REAL(SUMA/SUMB) + ENDDO + ELSE + DO IG=1,NG + GAR1A(IMIL,IFIS,IG)=0.0 + GAR1B(IMIL,IFIS,IG)=0.0 + ENDDO + ENDIF + ENDDO + ENDDO + DO IG=1,NG + KPMAC1=LCMGIL(JPMAC1,IG) + CALL LCMPUT(KPMAC1,'CHI'//CM,NMIL*NF,2,GAR1A(1,1,IG)) + CALL LCMPUT(KPMAC1,'NUSIGF'//CM,NMIL*NF,2,GAR1B(1,1,IG)) + ENDDO + ENDDO +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(GAR3,GAR2,GAR1B,GAR1A) + DEALLOCATE(IPOS,NJJ,IJJ) + RETURN + END |