diff options
Diffstat (limited to 'Dragon/src/TONCMI.f')
| -rw-r--r-- | Dragon/src/TONCMI.f | 239 |
1 files changed, 239 insertions, 0 deletions
diff --git a/Dragon/src/TONCMI.f b/Dragon/src/TONCMI.f new file mode 100644 index 0000000..6159c09 --- /dev/null +++ b/Dragon/src/TONCMI.f @@ -0,0 +1,239 @@ +*DECK TONCMI + SUBROUTINE TONCMI(IPMICR,IPRINT,NMERGE,NISOT,NGCOND,NL,NED,NDEL, + 1 MASKI,SPH) +* +*----------------------------------------------------------------------- +* +*Purpose: +* SPH-correction of a Microlib. +* +*Copyright: +* Copyright (C) 2017 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 +* IPMICR pointer to the condensed microlib (L_LIBRARY signature). +* IPRINT print flag (equal to 0 for no print). +* NMERGE number of merged regions. +* NISOT number of isotopes in microlib. +* NGCOND number of condensed groups. +* NL number of Legendre orders in scattering info. +* NED number of additional phi-weighted edits in microlib. +* NDEL number of delayed precursor groups. +* MASKI isotope mask (=.TRUE. if an isotope is to be corrected). +* SPH SPH homogenization factors. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPMICR + INTEGER IPRINT,NMERGE,NISOT,NGCOND,NL,NED,NDEL + LOGICAL MASKI(NISOT) + REAL SPH(NMERGE,NGCOND) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + INTEGER ISTATE(NSTATE) + TYPE(C_PTR) KPMICR + CHARACTER HSIGN*12,TEXT12*12,CM*2,TEXT8*8,HSMG*131,HMAKE(100)*12 + DOUBLE PRECISION DSUM +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: IMIX,ITYPR + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHUSED,IHEDIT + REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: WSCAT + TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO +*---- +* SCRATCH STORAGE ALLOCATION +* IHEDIT character*8 names of phi-weighted edits in microlib. +*---- + ALLOCATE(IHEDIT(2,NED+1),ITYPR(NL)) + ALLOCATE(GAR(NGCOND,10+NL+NED+2*NDEL),WSCAT(NGCOND,NGCOND,NL)) + ALLOCATE(IHUSED(3,NISOT),IMIX(NISOT),IPISO(NISOT)) +*---- +* RECOVER MICROLIB INFORMATION +*---- + CALL LCMGTC(IPMICR,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_LIBRARY') CALL XABORT('TONCMI: MICROLIB EXPECTED') + CALL LCMGET(IPMICR,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NMERGE) CALL XABORT('TONCMI: INVALID NMERGE') + IF(ISTATE(2).NE.NISOT) CALL XABORT('TONCMI: INVALID NISOT') + IF(ISTATE(3).NE.NGCOND) CALL XABORT('TONCMI: INVALID NGCOND') + IF(ISTATE(4).NE.NL) CALL XABORT('TONCMI: INVALID NL') + IF(ISTATE(13).NE.NED) CALL XABORT('TONCMI: INVALID NED') + IF(ISTATE(19).NE.NDEL) CALL XABORT('TONCMI: INVALID NDEL') + IF(NED.GT.0) CALL LCMGET(IPMICR,'ADDXSNAME-P0',IHEDIT) +*---- +* LOOP OVER ISOTOPES +*---- + CALL LCMGET(IPMICR,'ISOTOPESUSED',IHUSED) + CALL LCMGET(IPMICR,'ISOTOPESMIX',IMIX) + CALL LIBIPS(IPMICR,NISOT,IPISO) + DO 200 ISOT=1,NISOT + IF(.NOT.MASKI(ISOT)) GO TO 200 + WRITE(TEXT12,'(3A4)') (IHUSED(I0,ISOT),I0=1,3) + IF(IPRINT.GT.2) THEN + WRITE(6,'(29H TONCMI: PROCESSING ISOTOPE '',A12,2H''.)') TEXT12 + ENDIF + IBM=IMIX(ISOT) + KPMICR=IPISO(ISOT) ! set ISOT-th isotope + IF(.NOT.C_ASSOCIATED(KPMICR)) THEN + WRITE(HSMG,'(17HTONCMI: ISOTOPE '',A12,16H'' IS NOT AVAILAB, + > 19HLE IN THE MICROLIB.)') TEXT12 + CALL XABORT(HSMG) + ENDIF + MAXH=10+NL+NED+2*NDEL + IF(MAXH+NL.GT.100) CALL XABORT('TONCMI: STATIC STORAGE EXCEEDED') + DO 10 J=1,MAXH+NL + HMAKE(J)=' ' + 10 CONTINUE + GAR(:NGCOND,:10+NL+NED+2*NDEL)=0.0 + WSCAT(:NGCOND,:NGCOND,:NL)=0.0 +*---- +* RECOVER CALCULATION-SPECIFIC ISOTOPIC DATA +*---- + CALL LCMGET(KPMICR,'NWT0',GAR(1,1)) + HMAKE(1)='NWT0' + CALL LCMLEN(KPMICR,'NWT1',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,'NWT1',GAR(1,2)) + HMAKE(2)='NWT1' + ENDIF + CALL XDRLGS(KPMICR,-1,IPRINT,0,NL-1,1,NGCOND,GAR(1,3),WSCAT,ITYPR) + DO 30 IL=0,NL-1 + IF(ITYPR(IL+1).NE.0) THEN + WRITE (CM,'(I2.2)') IL + HMAKE(3+IL)='SIGS'//CM + ENDIF + 30 CONTINUE + CALL LCMGET(KPMICR,'NTOT0',GAR(1,3+NL)) + HMAKE(3+NL)='NTOT0' + CALL LCMLEN(KPMICR,'NTOT1',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + HMAKE(4+NL)='NTOT1' + CALL LCMGET(KPMICR,'NTOT1',GAR(1,4+NL)) + ENDIF + CALL LCMLEN(KPMICR,'NUSIGF',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,'NUSIGF',GAR(1,5+NL)) + HMAKE(5+NL)='NUSIGF' + ENDIF + IF(NDEL.GT.0) THEN + WRITE(TEXT12,'(6HNUSIGF,I2.2)') NDEL + CALL LCMLEN(KPMICR,TEXT12,LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + DO 40 IDEL=1,NDEL + WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL + CALL LCMGET(KPMICR,TEXT12,GAR(1,MAXH-2*NDEL-2+IDEL)) + HMAKE(MAXH-2*NDEL-2+IDEL)=TEXT12 + 40 CONTINUE + ENDIF + ENDIF + CALL LCMLEN(KPMICR,'H-FACTOR',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,'H-FACTOR',GAR(1,MAXH-2*NDEL-4)) + HMAKE(MAXH-2*NDEL-4)='H-FACTOR' + ENDIF + CALL LCMLEN(KPMICR,'OVERV',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,'OVERV',GAR(1,MAXH-2*NDEL-3)) + HMAKE(MAXH-2*NDEL-3)='OVERV' + ENDIF + CALL LCMLEN(KPMICR,'TRANC',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,'TRANC',GAR(1,MAXH-2*NDEL-2)) + HMAKE(MAXH-2*NDEL-2)='TRANC' + ENDIF + DO 60 IED=1,NED + WRITE(TEXT8,'(2A4)') (IHEDIT(I0,IED),I0=1,2) + CALL LCMLEN(KPMICR,TEXT8,LENGTH,ITYLCM) + IF((LENGTH.GT.0).AND.(TEXT8.NE.'TRANC')) THEN + CALL LCMGET(KPMICR,TEXT8,GAR(1,5+NL+IED)) + HMAKE(5+NL+IED)=TEXT8 + ENDIF + 60 CONTINUE + CALL LCMLEN(KPMICR,'STRD',LENGTH,ITYLCM) + IF(LENGTH.EQ.NGCOND) THEN + CALL LCMGET(KPMICR,'STRD',GAR(1,MAXH)) + HMAKE(MAXH)='STRD' + ENDIF +*---- +* APPLY SPH CORRECTION +*---- + DO 80 J=1,MAXH + IF((HMAKE(J).NE.' ').AND.(HMAKE(J)(:4).NE.'SIGS')) THEN + DO 70 IG=1,NGCOND + IF((HMAKE(J)(:4).EQ.'STRD').OR.(HMAKE(J).EQ.'NWT0').OR. + > (HMAKE(J).EQ.'TRANC')) THEN + GAR(IG,J)=GAR(IG,J)/SPH(IBM,IG) + ELSE IF(HMAKE(J)(:5).EQ.'NWT1') THEN + CONTINUE + ELSE IF(HMAKE(J)(:4).EQ.'NTOT') THEN + CONTINUE + ELSE + GAR(IG,J)=GAR(IG,J)*SPH(IBM,IG) + ENDIF + 70 CONTINUE + ENDIF + 80 CONTINUE + DO 105 IL=1,NL + ITYPR(IL)=0 + IF(HMAKE(MAXH+IL+1).NE.' ') ITYPR(IL)=1 + DO 100 IG2=1,NGCOND + DSUM=0.0 + DO 90 IG1=1,NGCOND + IF(MOD(IL-1,2).EQ.0) THEN + IF(IG1.EQ.IG2) THEN + WSCAT(IG1,IG1,IL)=WSCAT(IG1,IG1,IL)*SPH(IBM,IG1) + > +GAR(IG1,3+NL)*(1.0-SPH(IBM,IG1)) + ELSE + WSCAT(IG1,IG2,IL)=WSCAT(IG1,IG2,IL)*SPH(IBM,IG2) ! IG1 <- IG2 + ENDIF + ELSE + IF(IG1.EQ.IG2) THEN + WSCAT(IG1,IG1,IL)=WSCAT(IG1,IG1,IL)/SPH(IBM,IG1) + > +GAR(IG1,4+NL)*(1.0-1.0/SPH(IBM,IG1)) + ELSE + WSCAT(IG1,IG2,IL)=WSCAT(IG1,IG2,IL)/SPH(IBM,IG1) + ENDIF + ENDIF + DSUM=DSUM+WSCAT(IG1,IG2,IL) + 90 CONTINUE + IF(IL.EQ.1) THEN + GAR(IG2,2+IL)=GAR(IG2,2+IL)*SPH(IBM,IG2)+GAR(IG2,3+NL)* + 1 (1.0-SPH(IBM,IG2)) + ELSE + GAR(IG2,2+IL)=REAL(DSUM) + ENDIF + 100 CONTINUE + 105 CONTINUE +*---- +* SAVE CORRECTED INFORMATION ON LCM +*---- + DO 110 J=1,MAXH + IF((HMAKE(J).NE.' ').AND.(HMAKE(J)(:4).NE.'SIGS')) THEN + CALL LCMPUT(KPMICR,HMAKE(J),NGCOND,2,GAR(1,J)) + ENDIF + 110 CONTINUE + CALL XDRLGS(KPMICR,1,IPRINT,0,NL-1,1,NGCOND,GAR(1,3),WSCAT,ITYPR) + 200 CONTINUE + IF(IPRINT.GT.2) WRITE(6,'(/28H TONCMI: MICROLIB CORRECTED.)') +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(IPISO,IMIX,IHUSED) + DEALLOCATE(WSCAT,GAR) + DEALLOCATE(ITYPR,IHEDIT) + RETURN + END |