diff options
Diffstat (limited to 'Donjon/src/PCRISO.f')
| -rw-r--r-- | Donjon/src/PCRISO.f | 239 |
1 files changed, 239 insertions, 0 deletions
diff --git a/Donjon/src/PCRISO.f b/Donjon/src/PCRISO.f new file mode 100644 index 0000000..26803e3 --- /dev/null +++ b/Donjon/src/PCRISO.f @@ -0,0 +1,239 @@ +*DECK PCRISO + SUBROUTINE PCRISO(IPLIB,KPTMP,HNAME,JSO,NCAL,NGRP,NL,NED,HVECT, + 1 NDEL,IMPX,TERP) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Recover nuclear data from a single isotopic directory. +* +*Copyright: +* Copyright (C) 2019 Ecole Polytechnique de Montreal +* +*Author(s): +* A. Hebert +* +*Parameters: input +* IPLIB address of the microlib LCM object. +* KPTMP address of the 'CALCULATIONS' list. +* HNAME character*12 name of the PMAXS isotope been processed. +* JSO index of the PMAXS isotope been processed. +* NCAL number of elementary calculations in the PMAXS file. +* NGRP number of energy groups. +* NL number of Legendre orders. +* NED number of extra vector edits. +* HVECT character names of the extra vector edits. +* NDEL number of delayed precursor groups. +* IMPX print parameter (equal to zero for no print). +* TERP interpolation weights. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB,KPTMP + INTEGER JSO,NCAL,NGRP,NL,NED,NDEL,IMPX + REAL TERP(NCAL) + CHARACTER HNAME*12,HVECT(NED)*(*) +*---- +* LOCAL VARIABLES +*---- + INTEGER, PARAMETER::IOUT=6 + REAL TAUXFI, TAUXF, WEIGHT + INTEGER ICAL, IDEL, IED, IG1, IG2, IG, ILENG, IL, ITYLCM, J, + & LENGTH, MAXH + LOGICAL LWD + CHARACTER CM*2,HMAKE(100)*12,TEXT12*12 + TYPE(C_PTR) LPTMP,MPTMP,NPTMP + INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPR + REAL, ALLOCATABLE, DIMENSION(:) :: WDLA + REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR1,GAR2 + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: WSCA1,WSCA2 +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(ITYPR(NL)) + ALLOCATE(GAR1(NGRP,10+NL+NED+2*NDEL),WSCA1(NGRP,NGRP,NL), + 1 GAR2(NGRP,10+NL+NED+2*NDEL),WSCA2(NGRP,NGRP,NL),WDLA(NDEL)) +*---- +* RECOVER GENERIC ISOTOPIC DATA FROM THE PMAXS FILE +*---- + LWD=.FALSE. + DO 10 ICAL=1,NCAL + WEIGHT=TERP(ICAL) + IF(WEIGHT.EQ.0.0) GO TO 10 + LPTMP=LCMGIL(KPTMP,ICAL) + CALL LCMLEN(LPTMP,'ISOTOPESLIST',LENGTH,ITYLCM) + IF(LENGTH.EQ.0) GO TO 10 + MPTMP=LCMGID(LPTMP,'ISOTOPESLIST') + CALL LCMLEL(MPTMP,JSO,ILENG,ITYLCM) + IF(ILENG.EQ.0) GO TO 10 + NPTMP=LCMGIL(MPTMP,JSO) + CALL LCMGTC(NPTMP,'ALIAS',12,TEXT12) + IF(TEXT12(:8).NE.HNAME(:8)) GO TO 10 + CALL LCMLEN(NPTMP,'LAMBDA-D',LENGTH,ITYLCM) + LWD=(LENGTH.EQ.NDEL).AND.(NDEL.GT.0) + IF(LWD) CALL LCMGET(NPTMP,'LAMBDA-D',WDLA) + GO TO 15 + 10 CONTINUE + CALL XABORT('PCRISO: UNABLE TO FIND A DIRECTORY FOR ISOTOPE '// + 1 HNAME//'.') +*---- +* LOOP OVER ELEMENTARY CALCULATIONS +*---- + 15 MAXH=10+NL+NED+2*NDEL + IF(MAXH+NL.GT.100) CALL XABORT('PCRISO: STATIC STORAGE EXCEEDED') + DO J=1,MAXH+NL + HMAKE(J)=' ' + ENDDO + GAR2(:NGRP,:MAXH)=0.0 + WSCA2(:NGRP,:NGRP,:NL)=0.0 + TAUXFI=0.0 + DO 120 ICAL=1,NCAL + WEIGHT=TERP(ICAL) + IF(WEIGHT.EQ.0.0) GO TO 120 + LPTMP=LCMGIL(KPTMP,ICAL) + IF(IMPX.GT.4) THEN + WRITE(IOUT,'(34H PCRISO: PMAXS ACCESS FOR ISOTOPE ,A,6H AND C, + 1 10HALCULATION,I5,1H.)') HNAME,ICAL + IF(IMPX.GT.50) CALL LCMLIB(LPTMP) + ENDIF + MPTMP=LCMGID(LPTMP,'ISOTOPESLIST') + CALL LCMLEL(MPTMP,JSO,ILENG,ITYLCM) + IF(ILENG.EQ.0) GO TO 120 + NPTMP=LCMGIL(MPTMP,JSO) +*---- +* RECOVER CALCULATION-SPECIFIC ISOTOPIC DATA FROM THE PMAXS FILE +*---- + CALL LCMLEN(NPTMP,'NWT0',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + CALL LCMGET(NPTMP,'NWT0',GAR1(1,1)) + HMAKE(1)='NWT0' + ENDIF + CALL LCMLEN(NPTMP,'NWT1',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + CALL LCMGET(NPTMP,'NWT1',GAR1(1,2)) + HMAKE(2)='NWT1' + ENDIF + CALL XDRLGS(NPTMP,-1,IMPX,0,NL-1,1,NGRP,GAR1(1,3),WSCA1,ITYPR) + DO IL=0,NL-1 + IF(ITYPR(IL+1).NE.0) THEN + WRITE (CM,'(I2.2)') IL + HMAKE(3+IL)='SIGS'//CM + ENDIF + ENDDO + CALL LCMGET(NPTMP,'NTOT0',GAR1(1,3+NL)) + HMAKE(3+NL)='NTOT0' + CALL LCMLEN(NPTMP,'NTOT1',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + CALL LCMGET(NPTMP,'NTOT1',GAR1(1,4+NL)) + HMAKE(4+NL)='NTOT1' + ENDIF + CALL LCMLEN(NPTMP,'NUSIGF',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + CALL LCMGET(NPTMP,'NUSIGF',GAR1(1,5+NL)) + HMAKE(5+NL)='NUSIGF' + CALL LCMGET(NPTMP,'CHI',GAR1(1,MAXH-NDEL-1)) + HMAKE(MAXH-NDEL-1)='CHI' + ENDIF + IF(NDEL.GT.0) THEN + WRITE(TEXT12,'(6HNUSIGF,I2.2)') NDEL + CALL LCMLEN(NPTMP,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + DO IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + CALL LCMGET(NPTMP,TEXT12,GAR1(1,MAXH-2*NDEL-2+IDEL)) + HMAKE(MAXH-2*NDEL-2+IDEL)=TEXT12 + ENDDO + ENDIF + WRITE(TEXT12,'(3HCHI,I2.2)') NDEL + CALL LCMLEN(NPTMP,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + DO IDEL=1,NDEL + WRITE(TEXT12,'(3HCHI,I2.2)') IDEL + CALL LCMGET(NPTMP,TEXT12,GAR1(1,MAXH-NDEL-1+IDEL)) + HMAKE(MAXH-NDEL-1+IDEL)=TEXT12 + ENDDO + ENDIF + ENDIF + CALL LCMLEN(NPTMP,'H-FACTOR',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + CALL LCMGET(NPTMP,'H-FACTOR',GAR1(1,MAXH-2*NDEL-4)) + HMAKE(MAXH-2*NDEL-4)='H-FACTOR' + ENDIF + CALL LCMLEN(NPTMP,'OVERV',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + CALL LCMGET(NPTMP,'OVERV',GAR1(1,MAXH-2*NDEL-3)) + HMAKE(MAXH-2*NDEL-3)='OVERV' + ENDIF + CALL LCMLEN(NPTMP,'TRANC',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + CALL LCMGET(NPTMP,'TRANC',GAR1(1,MAXH-2*NDEL-2)) + HMAKE(MAXH-2*NDEL-2)='TRANC' + ENDIF + DO IED=1,NED + CALL LCMLEN(NPTMP,HVECT(IED),LENGTH,ITYLCM) + IF((LENGTH.GT.0).AND.(HVECT(IED).NE.'TRANC')) THEN + CALL LCMGET(NPTMP,HVECT(IED),GAR1(1,5+NL+IED)) + HMAKE(5+NL+IED)=HVECT(IED) + ENDIF + ENDDO + CALL LCMLEN(NPTMP,'STRD',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGRP) THEN + CALL LCMGET(NPTMP,'STRD',GAR1(1,MAXH)) + HMAKE(MAXH)='STRD' + ENDIF +*---- +* COMPUTE FISSION RATE FOR A SINGLE ELEMENTARY CALCULATION +*---- + TAUXF=0.0 + IF(HMAKE(5+NL).EQ.'NUSIGF') THEN + DO IG=1,NGRP + TAUXF=TAUXF+GAR1(IG,5+NL)*GAR1(IG,1) + ENDDO + TAUXFI=TAUXFI+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 + GAR2(IG,J)=GAR2(IG,J)+WEIGHT*GAR1(IG,J) + ENDDO + ENDIF + ENDDO + DO IL=1,NL + ITYPR(IL)=0 + IF(HMAKE(MAXH+IL).NE.' ') ITYPR(IL)=1 + DO IG2=1,NGRP + GAR2(IG2,2+IL)=GAR2(IG2,2+IL)+WEIGHT*GAR1(IG2,2+IL) + DO IG1=1,NGRP + WSCA2(IG1,IG2,IL)=WSCA2(IG1,IG2,IL)+WEIGHT* + 1 WSCA1(IG1,IG2,IL) + ENDDO + ENDDO + ENDDO + 120 CONTINUE +*---- +* SAVE ISOTOPIC DATA IN THE MICROLIB +*---- + CALL LCMPTC(IPLIB,'ALIAS',12,HNAME) + 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,3),WSCA2,ITYPR) + IF(IMPX.GT.50) CALL LCMLIB(IPLIB) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(WDLA,WSCA2,GAR2,WSCA1,GAR1) + DEALLOCATE(ITYPR) + RETURN + END |