*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