diff options
Diffstat (limited to 'Donjon/src/NCRISO.f')
| -rw-r--r-- | Donjon/src/NCRISO.f | 338 |
1 files changed, 338 insertions, 0 deletions
diff --git a/Donjon/src/NCRISO.f b/Donjon/src/NCRISO.f new file mode 100644 index 0000000..bce4633 --- /dev/null +++ b/Donjon/src/NCRISO.f @@ -0,0 +1,338 @@ +*DECK NCRISO + SUBROUTINE NCRISO(IPLIB,LPCPO,NBISO1,IMICR,HNAME,JSO,IBM,NCAL, + 1 NGRP,NL,NW,NED,HVECT,NDEL,NBESP,NDFI,IMPX,FACT,TERP,LPURE) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover nuclear data from a single isotopic directory. +* +*Copyright: +* Copyright (C) 2006 Ecole Polytechnique de Montreal +* +*Author(s): +* A. Hebert +* +*Parameters: input +* IPLIB address of the microlib LCM object. +* LPCPO address of the 'CALCULATIONS' tree in the multidimensional +* multicompo object. +* NBISO1 number of multicompo isotopes. +* IMICR index of microlib isotope corresponding to each multicompo +* isotope in mixture IBM. +* HNAME character*12 name of the multicompo isotope been processed. +* JSO index of the multicompo isotope been processed. +* IBM mixture index. +* NCAL number of elementary calculations in the multicompo object. +* NGRP number of energy groups. +* NL number of Legendre orders. +* NW type of weighting for P1 cross section info (=0 P0; =1 P1). +* NED number of extra vector edits. +* HVECT character names of the extra vector edits. +* NDEL number of delayed precursor groups. +* NBESP number of energy-dependent fission spectra. +* NDFI number of fissile isotopes. +* IMPX print parameter (equal to zero for no print). +* FACT number density factors. +* TERP interpolation weights. +* LPURE flag set to .true. to avoid non-linear interpolation effects. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,LPCPO + INTEGER NBISO1,IMICR(NBISO1),JSO,IBM,NCAL,NGRP,NL,NW,NED,NDEL, + 1 NBESP,NDFI,IMPX + REAL FACT(NCAL),TERP(NCAL) + CHARACTER HNAME*12,HVECT(NED)*(*) + LOGICAL LPURE +*---- +* LOCAL VARIABLES +*---- + INTEGER, PARAMETER::IOUT=6 + REAL AWR, DECAY, EMEVF, EMEVG, FACT0, TAUXFI, TAUXF, WEIGHT + INTEGER ICAL, IDEL, ISP, IED, IFI, IG1, IG2, IG, ILENG, IL, + & ITYLCM, J, LENGTH, IW, MAXH, IOF, IOF2H + LOGICAL LAWR,LMEVF,LMEVG,LDECA,LWD,LYIELD,LPIFI + CHARACTER CM*2,TEXT12*12 + TYPE(C_PTR) MPCPO,NPCPO,OPCPO + INTEGER, ALLOCATABLE, DIMENSION(:) :: JPIF1,JPIF2,ITYPR + REAL, ALLOCATABLE, DIMENSION(:) :: YIEL1,PYIE1,YIEL2,PYIE2,WDLA + REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR1,GAR2 + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: WSCA1,WSCA2 + CHARACTER(LEN=12), ALLOCATABLE, DIMENSION(:) :: HMAKE +*---- +* SCRATCH STORAGE ALLOCATION +*---- + MAXH=9+3*NW+NL+NED+2*NDEL+NBESP + ALLOCATE(JPIF1(NDFI),JPIF2(NDFI),ITYPR(NL)) + ALLOCATE(GAR1(NGRP,MAXH),YIEL1(NGRP+1),PYIE1(NDFI), + 1 WSCA1(NGRP,NGRP,NL),GAR2(NGRP,MAXH),YIEL2(NGRP+1),PYIE2(NDFI), + 2 WSCA2(NGRP,NGRP,NL),WDLA(NDEL)) + ALLOCATE(HMAKE(MAXH+NL)) +*---- +* RECOVER GENERIC ISOTOPIC DATA FROM THE MULTICOMPO +*---- + LAWR=.FALSE. + LMEVF=.FALSE. + LMEVG=.FALSE. + LDECA=.FALSE. + LYIELD=.FALSE. + LPIFI=.FALSE. + LWD=.FALSE. + DO 10 ICAL=1,NCAL + MPCPO=LCMGIL(LPCPO,ICAL) + CALL LCMLEN(MPCPO,'ISOTOPESLIST',LENGTH,ITYLCM) + IF(LENGTH.EQ.0) GO TO 10 + NPCPO=LCMGID(MPCPO,'ISOTOPESLIST') + CALL LCMLEL(NPCPO,JSO,ILENG,ITYLCM) + IF(ILENG.EQ.0) GO TO 10 + OPCPO=LCMGIL(NPCPO,JSO) + CALL LCMGTC(OPCPO,'ALIAS',12,TEXT12) + IF(TEXT12(:8).NE.HNAME(:8)) GO TO 10 + CALL LCMLEN(OPCPO,'AWR',LENGTH,ITYLCM) + IF(LENGTH.EQ.1) CALL LCMGET(OPCPO,'AWR',AWR) + LAWR=(LENGTH.EQ.1) + CALL LCMLEN(OPCPO,'MEVF',LENGTH,ITYLCM) + IF(LENGTH.EQ.1) CALL LCMGET(OPCPO,'MEVF',EMEVF) + LMEVF=(LENGTH.EQ.1) + CALL LCMLEN(OPCPO,'MEVG',LENGTH,ITYLCM) + IF(LENGTH.EQ.1) CALL LCMGET(OPCPO,'MEVG',EMEVG) + LMEVG=(LENGTH.EQ.1) + CALL LCMLEN(OPCPO,'DECAY',LENGTH,ITYLCM) + IF(LENGTH.EQ.1) CALL LCMGET(OPCPO,'DECAY',DECAY) + LDECA=(LENGTH.EQ.1) + CALL LCMLEN(OPCPO,'LAMBDA-D',LENGTH,ITYLCM) + LWD=(LENGTH.EQ.NDEL).AND.(NDEL.GT.0) + IF(LWD) CALL LCMGET(OPCPO,'LAMBDA-D',WDLA) + GO TO 15 + 10 CONTINUE + WRITE(6,170) IBM,HNAME + CALL XABORT('NCRISO: UNABLE TO FIND AN ISOTOPE DIRECTORY.') +*---- +* LOOP OVER ELEMENTARY CALCULATIONS +*---- + 15 DO J=1,MAXH+NL + HMAKE(J)=' ' + ENDDO + GAR2(:NGRP,:MAXH)=0.0 + WSCA2(:NGRP,:NGRP,:NL)=0.0 + YIEL2(:NGRP+1)=0.0 + PYIE2(:NDFI)=0.0 + JPIF2(:NDFI)=0 + TAUXFI=0.0 + DO 120 ICAL=1,NCAL + WEIGHT=TERP(ICAL) + IF(WEIGHT.EQ.0.0) GO TO 120 + FACT0=FACT(ICAL) + MPCPO=LCMGIL(LPCPO,ICAL) + IF(IMPX.GT.4) THEN + WRITE(IOUT,'(39H NCRISO: MULTICOMPO ACCESS FOR ISOTOPE ,A, + 1 16H AND CALCULATION,I5,1H.)') HNAME,ICAL + IF(IMPX.GT.50) CALL LCMLIB(MPCPO) + ENDIF + NPCPO=LCMGID(MPCPO,'ISOTOPESLIST') + CALL LCMLEL(NPCPO,JSO,ILENG,ITYLCM) + IF(ILENG.EQ.0) GO TO 120 + OPCPO=LCMGIL(NPCPO,JSO) +*---- +* RECOVER CALCULATION-SPECIFIC ISOTOPIC DATA FROM THE MULTICOMPO +*---- + DO IW=1,MIN(NW+1,10) + WRITE(TEXT12,'(3HNWT,I1)') IW-1 + CALL LCMLEN(OPCPO,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + CALL LCMGET(OPCPO,TEXT12,GAR1(1,IW)) + HMAKE(IW)=TEXT12 + ENDIF + WRITE(TEXT12,'(4HNWAT,I1)') IW-1 + CALL LCMLEN(OPCPO,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + CALL LCMGET(OPCPO,TEXT12,GAR1(1,1+NW+IW)) + HMAKE(1+NW+IW)=TEXT12 + ENDIF + WRITE(TEXT12,'(4HNTOT,I1)') IW-1 + CALL LCMLEN(OPCPO,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + CALL LCMGET(OPCPO,TEXT12,GAR1(1,2+2*NW+IW)) + HMAKE(2+2*NW+IW)=TEXT12 + ENDIF + ENDDO + CALL XDRLGS(OPCPO,-1,IMPX,0,NL-1,1,NGRP,GAR1(1,4+3*NW),WSCA1, + 1 ITYPR) + DO IL=0,NL-1 + IF(ITYPR(IL+1).NE.0) THEN + WRITE (CM,'(I2.2)') IL + HMAKE(4+3*NW+IL)='SIGS'//CM + ENDIF + ENDDO + CALL LCMLEN(OPCPO,'NUSIGF',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + CALL LCMGET(OPCPO,'NUSIGF',GAR1(1,4+3*NW+NL)) + HMAKE(4+3*NW+NL)='NUSIGF' + CALL LCMGET(OPCPO,'CHI',GAR1(1,5+3*NW+NL)) + HMAKE(5+3*NW+NL)='CHI' + ENDIF + IF(NDEL.GT.0) THEN + WRITE(TEXT12,'(6HNUSIGF,I2.2)') NDEL + CALL LCMLEN(OPCPO,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + DO IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + CALL LCMGET(OPCPO,TEXT12,GAR1(1,5+3*NW+NL+IDEL)) + HMAKE(5+3*NW+NL+IDEL)=TEXT12 + ENDDO + ENDIF + WRITE(TEXT12,'(3HCHI,I2.2)') NDEL + CALL LCMLEN(OPCPO,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + DO IDEL=1,NDEL + WRITE(TEXT12,'(3HCHI,I2.2)') IDEL + CALL LCMGET(OPCPO,TEXT12,GAR1(1,5+3*NW+NL+NDEL+IDEL)) + HMAKE(5+3*NW+NL+NDEL+IDEL)=TEXT12 + ENDDO + ENDIF + ENDIF + IOF2H=9+NED+NL+3*NW+2*NDEL + DO ISP=1,NBESP + WRITE(TEXT12,'(5HCHI--,I2.2)') ISP + CALL LCMLEN(OPCPO,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + CALL LCMGET(OPCPO,TEXT12,GAR1(1,IOF2H+ISP)) + HMAKE(IOF2H+ISP)=TEXT12 + ENDIF + ENDDO + CALL LCMLEN(OPCPO,'H-FACTOR',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + CALL LCMGET(OPCPO,'H-FACTOR',GAR1(1,6+3*NW+NL+2*NDEL)) + HMAKE(6+3*NW+NL+2*NDEL)='H-FACTOR' + ENDIF + CALL LCMLEN(OPCPO,'OVERV',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + CALL LCMGET(OPCPO,'OVERV',GAR1(1,7+3*NW+NL+2*NDEL)) + HMAKE(7+3*NW+NL+2*NDEL)='OVERV' + ENDIF + CALL LCMLEN(OPCPO,'TRANC',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + CALL LCMGET(OPCPO,'TRANC',GAR1(1,8+3*NW+NL+2*NDEL)) + HMAKE(8+3*NW+NL+2*NDEL)='TRANC' + ENDIF + DO IED=1,NED + CALL LCMLEN(OPCPO,HVECT(IED),LENGTH,ITYLCM) + IF((LENGTH.GT.0).AND.(HVECT(IED).NE.'TRANC')) THEN + CALL LCMGET(OPCPO,HVECT(IED),GAR1(1,8+3*NW+NL+2*NDEL+IED)) + HMAKE(8+3*NW+NL+2*NDEL+IED)=HVECT(IED) + ENDIF + ENDDO + CALL LCMLEN(OPCPO,'STRD',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + CALL LCMGET(OPCPO,'STRD',GAR1(1,9+3*NW+NL+NED+2*NDEL)) + HMAKE(9+3*NW+NL+NED+2*NDEL)='STRD' + ENDIF +*---- +* RECOVER FISSION YIELD DATA +*---- + CALL LCMLEN(OPCPO,'YIELD',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP+1) THEN + CALL LCMGET(OPCPO,'YIELD',YIEL1) + LYIELD=.TRUE. + DO IG=1,NGRP+1 + YIEL2(IG)=YIEL2(IG)+WEIGHT*YIEL1(IG) + ENDDO + ENDIF + CALL LCMLEN(OPCPO,'PYIELD',LENGTH,ITYLCM) + IF((LENGTH.GT.0).AND.(LENGTH.EQ.NDFI)) THEN + CALL LCMGET(OPCPO,'PIFI',JPIF1) + CALL LCMGET(OPCPO,'PYIELD',PYIE1) + LPIFI=.TRUE. + DO IFI=1,NDFI + IF(JPIF1(IFI).GT.0) JPIF2(IFI)=IMICR(JPIF1(IFI)) + PYIE2(IFI)=PYIE2(IFI)+WEIGHT*PYIE1(IFI) + ENDDO + ENDIF +*---- +* COMPUTE FISSION RATE FOR A SINGLE ELEMENTARY CALCULATION +*---- + TAUXF=0.0 + IF(HMAKE(4+3*NW+NL).EQ.'NUSIGF') THEN + DO IG=1,NGRP + TAUXF=TAUXF+GAR1(IG,4+3*NW+NL)*GAR1(IG,1) + ENDDO + TAUXFI=TAUXFI+FACT0*WEIGHT*TAUXF + ENDIF +*---- +* ADD CONTRIBUTIONS FROM A SINGLE ELEMENTARY CALCULATION +*---- + DO J=1,MAXH + IF((HMAKE(J).NE.' ').AND.(HMAKE(J)(:4).NE.'SIGS')) THEN + DO IG=1,NGRP + IF((HMAKE(J)(:2).EQ.'NW').OR.(HMAKE(J).EQ.'OVERV')) THEN + GAR2(IG,J)=GAR2(IG,J)+WEIGHT*GAR1(IG,J) + ELSE IF((HMAKE(J)(:3).EQ.'CHI').AND.(.NOT.LPURE)) THEN + GAR2(IG,J)=GAR2(IG,J)+FACT0*WEIGHT*TAUXF*GAR1(IG,J) + ELSE + GAR2(IG,J)=GAR2(IG,J)+FACT0*WEIGHT*GAR1(IG,J) + ENDIF + ENDDO + ENDIF + ENDDO + DO IL=1,NL + IOF=3+3*NW+IL + ITYPR(IL)=0 + IF(HMAKE(MAXH+IL).NE.' ') ITYPR(IL)=1 + DO IG2=1,NGRP + GAR2(IG2,IOF)=GAR2(IG2,IOF)+FACT0*WEIGHT*GAR1(IG2,IOF) + DO IG1=1,NGRP + WSCA2(IG1,IG2,IL)=WSCA2(IG1,IG2,IL)+FACT0*WEIGHT* + 1 WSCA1(IG1,IG2,IL) + ENDDO + ENDDO + ENDDO + 120 CONTINUE +*---- +* NORMALIZE FISSION SPECTRA +*---- + IF(.NOT.LPURE) THEN + DO J=1,MAXH + IF(HMAKE(J)(:3).EQ.'CHI') THEN + DO IG=1,NGRP + IF(GAR2(IG,J).NE.0.0) GAR2(IG,J)=GAR2(IG,J)/TAUXFI + ENDDO + ENDIF + ENDDO + ENDIF +*---- +* SAVE ISOTOPIC DATA IN THE MICROLIB +*---- + CALL LCMPTC(IPLIB,'ALIAS',12,HNAME) + IF(LAWR) CALL LCMPUT(IPLIB,'AWR',1,2,AWR) + IF(LMEVF) CALL LCMPUT(IPLIB,'MEVF',1,2,EMEVF) + IF(LMEVG) CALL LCMPUT(IPLIB,'MEVG',1,2,EMEVG) + IF(LDECA) CALL LCMPUT(IPLIB,'DECAY',1,2,DECAY) + IF(LYIELD) CALL LCMPUT(IPLIB,'YIELD',NGRP+1,2,YIEL2) + IF(LPIFI) THEN + CALL LCMPUT(IPLIB,'PYIELD',NDFI,2,PYIE2) + CALL LCMPUT(IPLIB,'PIFI',NDFI,1,JPIF2) + ENDIF + IF(LWD) CALL LCMPUT(IPLIB,'LAMBDA-D',NDEL,2,WDLA) + DO J=1,MAXH + IF((HMAKE(J).NE.' ').AND.(HMAKE(J)(:4).NE.'SIGS')) THEN + CALL LCMPUT(IPLIB,HMAKE(J),NGRP,2,GAR2(1,J)) + ENDIF + ENDDO + CALL XDRLGS(IPLIB,1,IMPX,0,NL-1,1,NGRP,GAR2(1,4+3*NW),WSCA2,ITYPR) + IF(IMPX.GT.50) CALL LCMLIB(IPLIB) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(HMAKE) + DEALLOCATE(WDLA,WSCA2,PYIE2,YIEL2,GAR2,WSCA1,PYIE1,YIEL1,GAR1) + DEALLOCATE(ITYPR,JPIF2,JPIF1) + RETURN +* + 170 FORMAT(17H NCRISO: MIXTURE=,I5,10H ISOTOPE=',A12,2H'.) + END |