*DECK SPHCPO SUBROUTINE SPHCPO(MAXISO,IPLIB,IPCPO,NMIL,NGRP,IMPX,ICAL,ILUPS,B2) * *----------------------------------------------------------------------- * *Purpose: * Extract a Microlib corresponding to an elementary calculation in a * Multicompo. * *Copyright: * Copyright (C) 2012 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 * MAXISO maximum allocated space for output microlib TOC information. * IPLIB address of the output microlib LCM object. * IPCPO address of the multicompo object. * NMIL number of mixtures in the elementary calculation. * NGRP number of energy groups. * IMPX print parameter (equal to zero for no print). * ICAL index of the elementary calculation being considered. * ILUPS up-scattering removing flag (=1 to remove up-scattering from * output cross-sections). * *Parameters: output * B2 buckling recovered from the Multicompo. * *----------------------------------------------------------------------- * USE GANLIB *---- * SUBROUTINE ARGUMENTS *---- TYPE(C_PTR) IPLIB,IPCPO INTEGER MAXISO,NMIL,NGRP,IMPX,ICAL,ILUPS REAL B2 *---- * LOCAL VARIABLES *---- PARAMETER (NSTATE=40,MAXED=50,IOUT=6) CHARACTER TEXT12*12,HSMG*131,HVECT1(MAXED)*8,HVECT2(MAXED)*8 INTEGER ISTATE(NSTATE) TYPE(C_PTR) JPLIB,KPLIB,JPCPO,KPCPO,LPCPO,MPCPO,NPCPO,OPCPO INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYP1,ITOD1,IMIX2,ITYP2, 1 ITOD2,MILVO,MUP INTEGER, ALLOCATABLE, DIMENSION(:,:) :: HUSE1,HNAM1,HUSE2,HNAM2 REAL, ALLOCATABLE, DIMENSION(:) :: DENS1,TEMP1,VOL1,DENS2,TEMP2, 1 VOL2,ENER,DELT,VOLMI2,GAR4 REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR6 REAL, ALLOCATABLE, DIMENSION(:,:,:) :: ADF2 CHARACTER(LEN=8), ALLOCATABLE, DIMENSION(:) :: HADF,HADF2 *---- * SCRATCH STORAGE ALLOCATION *---- ALLOCATE(HUSE1(3,MAXISO),HNAM1(3,MAXISO),ITYP1(MAXISO), 1 ITOD1(MAXISO),IMIX2(MAXISO),ITYP2(MAXISO),ITOD2(MAXISO), 2 HUSE2(3,MAXISO),HNAM2(3,MAXISO),MILVO(NMIL)) ALLOCATE(DENS1(MAXISO),TEMP1(MAXISO),VOL1(MAXISO),DENS2(MAXISO), 1 TEMP2(MAXISO),VOL2(MAXISO),ENER(NGRP+1),DELT(NGRP),VOLMI2(NMIL)) *---- * MICROLIB INITIALIZATION *---- IF(ILUPS.EQ.1) CALL XABORT('SPHCPO: UPS OPTION NOT IMPLEMENTED.') NBISO2=0 NCOMB2=0 NED2=0 TEXT12='L_LIBRARY' CALL LCMPTC(IPLIB,'SIGNATURE',12,TEXT12) DENS2(:MAXISO)=0.0 TEMP2(:MAXISO)=0.0 VOL2(:MAXISO)=0.0 VOLMI2(:NMIL)=0.0 IMIX2(:MAXISO)=0 ITYP2(:MAXISO)=0 ITOD2(:MAXISO)=0 *---- * RECOVER NDEPL *---- NDEPL=0 CALL LCMLEN(IPCPO,'DEPL-CHAIN',ILONG,ITYLCM) IF(ILONG.NE.0) THEN CALL LCMSIX(IPCPO,'DEPL-CHAIN',1) CALL LCMGET(IPCPO,'STATE-VECTOR',ISTATE) NDEPL=ISTATE(1) CALL LCMSIX(IPCPO,' ',2) ENDIF *---- * DETECT DISCONTINUITY FACTORS *---- JPCPO=LCMGID(IPCPO,'MIXTURES') KPCPO=LCMGIL(JPCPO,1) LPCPO=LCMGID(KPCPO,'CALCULATIONS') MPCPO=LCMGIL(LPCPO,1) CALL LCMGET(MPCPO,'STATE-VECTOR',ISTATE) IDF=ISTATE(24) NTYPE=0 IF(IDF.GT.0) THEN IF(IDF.EQ.1) THEN NTYPE=2 ELSE IF(IDF.EQ.2) THEN CALL LCMSIX(MPCPO,'MACROLIB',1) CALL LCMLEN(MPCPO,'ADF',ILONG,ITYLCM) IF(ILONG.EQ.0) CALL XABORT('SPHCPO: MISSING ADF DIRECTORY ' 1 //'IN MULTICOMPO OBJECT.') CALL LCMSIX(MPCPO,'ADF',1) CALL LCMGET(MPCPO,'NTYPE',NTYPE) CALL LCMSIX(MPCPO,' ',2) CALL LCMSIX(MPCPO,' ',2) ELSE CALL XABORT('SPHCPO: MATRIX ADF IS NOT IMPLEMENTED.') ENDIF ENDIF ALLOCATE(HADF(NTYPE),ADF2(NMIL,NGRP,NTYPE),GAR4(NGRP), 1 GAR6(NGRP,2)) IF((IDF.GE.2).AND.(NTYPE.GT.0)) THEN CALL LCMSIX(MPCPO,'MACROLIB',1) CALL LCMSIX(MPCPO,'ADF',1) CALL LCMGTC(MPCPO,'HADF',8,NTYPE,HADF) CALL LCMSIX(MPCPO,' ',2) CALL LCMSIX(MPCPO,' ',2) ENDIF *---- * LOOP OVER MICROLIB MIXTURES *---- MILVO(:NMIL)=0 NCOMB=0 JPCPO=LCMGID(IPCPO,'MIXTURES') ITRANC=0 NDEL=0 NDFI=0 NL=0 NW=0 DO 190 IBM=1,NMIL KPCPO=LCMGIL(JPCPO,IBM) LPCPO=LCMGID(KPCPO,'CALCULATIONS') *---- * SELECT ICAL-TH ELEMENTARY CALCULATION *---- IF(IMPX.GT.0) THEN WRITE(IOUT,'(33H SPHCPO: COMPO ACCESS FOR MIXTURE,I6,6H AND C, 1 10HALCULATION,I5)') IBM,ICAL ENDIF MPCPO=LCMGIL(LPCPO,ICAL) IF(IMPX.GT.50) CALL LCMLIB(MPCPO) CALL LCMGET(MPCPO,'STATE-VECTOR',ISTATE) NL=ISTATE(4) ITRANC=ISTATE(5) NDEPL=MAX(ISTATE(11),NDEPL) NDEL=ISTATE(19) NDFI=ISTATE(20) NW=MAX(NW,ISTATE(25)) IF(ISTATE(1).NE.1) CALL XABORT('SPHCPO: INVALID NUMBER OF MATERI' 1 //'AL MIXTURES IN THE COMPO.') IF(ISTATE(3).NE.NGRP) CALL XABORT('SPHCPO: INVALID NUMBER OF ENE' 1 //'RGY GROUPS IN THE COMPO.') IF(ISTATE(24).NE.IDF) CALL XABORT('SPHCPO: INVALID NUMBER OF DIS' 1 //'CONTINUITY FACTORS IN THE COMPO.') NBISO1=ISTATE(2) IF(NBISO1.GT.MAXISO) CALL XABORT('SPHCPO: MAXISO OVERFLOW(1).') NED1=ISTATE(13) IF(NED1.GT.MAXED) CALL XABORT('SPHCPO: MAXED OVERFLOW(1).') CALL LCMLEN(MPCPO,'MIXTURESVOL',ILONG,ITYLCM) IF(ILONG.GT.0) CALL LCMGET(MPCPO,'MIXTURESVOL',VOLMI2(IBM)) CALL LCMGET(MPCPO,'ISOTOPESUSED',HUSE1) CALL LCMGET(MPCPO,'ISOTOPERNAME',HNAM1) CALL LCMGET(MPCPO,'ISOTOPESDENS',DENS1) CALL LCMGET(MPCPO,'ISOTOPESTYPE',ITYP1) CALL LCMGET(MPCPO,'ISOTOPESTODO',ITOD1) CALL LCMGET(MPCPO,'ISOTOPESVOL',VOL1) CALL LCMGET(MPCPO,'ISOTOPESTEMP',TEMP1) B2=0.0 CALL LCMLEN(MPCPO,'B2 B1HOM',ILONG,ITYLCM) IF(ILONG.GT.0) CALL LCMGET(MPCPO,'B2 B1HOM',B2) IF(NED1.GT.0) CALL LCMGTC(MPCPO,'ADDXSNAME-P0',8,NED1,HVECT1) CALL LCMGET(MPCPO,'ENERGY',ENER) CALL LCMGET(MPCPO,'DELTAU',DELT) DO 30 IED1=1,NED1 DO 20 IED2=1,NED2 IF(HVECT1(IED1).EQ.HVECT2(IED2)) GO TO 30 20 CONTINUE NED2=NED2+1 IF(NED2.GT.MAXED) CALL XABORT('SPHCPO: MAXED OVERFLOW(2).') HVECT2(NED2)=HVECT1(IED1) 30 CONTINUE IF(IBM.GT.9999) CALL XABORT('SPHCPO: IBM OVERFLOW.') DO 100 ISO=1,NBISO1 ! compo isotope WRITE(TEXT12,'(2A4,I4.4)') (HUSE1(I,ISO),I=1,2),IBM DO 60 JSO=1,NBISO2 ! microlib isotope IF((HUSE1(1,ISO).EQ.HUSE2(1,JSO)).AND.(HUSE1(2,ISO).EQ. 1 HUSE2(2,JSO)).AND.(IMIX2(JSO).EQ.IBM)) THEN IF(ITYP1(ISO).NE.ITYP2(JSO)) THEN WRITE(HSMG,500) 'ITYP',ISO,ITYP1(ISO),ITYP2(JSO) CALL XABORT(HSMG) ENDIF JSO1=JSO GO TO 90 ENDIF 60 CONTINUE NBISO2=NBISO2+1 IF(NBISO2.GT.MAXISO) THEN WRITE(IOUT,'(/16H SPHCPO: NBISO2=,I6,8H MAXISO=,I6)') NBISO2, 1 MAXISO CALL XABORT('SPHCPO: MAXISO OVERFLOW(2).') ENDIF READ(TEXT12,'(3A4)') (HUSE2(I0,NBISO2),I0=1,3) DO 70 I0=1,3 HNAM2(I0,NBISO2)=HNAM1(I0,ISO) 70 CONTINUE IMIX2(NBISO2)=IBM ITYP2(NBISO2)=ITYP1(ISO) ITOD2(NBISO2)=ITOD1(ISO) IF(ITYP2(NBISO2).EQ.1) ITOD2(NBISO2)=1 DENS2(NBISO2)=0.0 JSO1=NBISO2 IF(ITOD2(NBISO2).NE.1) THEN DO 80 J=1,NCOMB IF(IBM.EQ.MILVO(J)) GO TO 90 80 CONTINUE NCOMB=NCOMB+1 IF(NCOMB.GT.NMIL) CALL XABORT('SPHCPO: MILVO OVERFLOW.') MILVO(NCOMB)=IBM ENDIF 90 DENS2(JSO1)=DENS1(ISO) VOL2(JSO1)=VOL1(ISO) TEMP2(JSO1)=TEMP1(ISO) 100 CONTINUE *---- * PROCESS ISOTOPE DIRECTORIES FOR MICROLIB MIXTURE IBM *---- JPLIB=LCMLID(IPLIB,'ISOTOPESLIST',NBISO2) DO 180 ISO=1,NBISO2 ! microlib isotope IF(IMIX2(ISO).NE.IBM) GO TO 180 DO 120 JSO=1,NBISO1 ! compo isotope IF((HUSE1(1,JSO).EQ.HUSE2(1,ISO)).AND.(HUSE1(2,JSO).EQ. 1 HUSE2(2,ISO))) THEN JSO1=JSO GO TO 130 ENDIF 120 CONTINUE WRITE(TEXT12,'(3A4)') (HUSE2(I0,ISO),I0=1,3) CALL XABORT('SPHCPO: UNABLE TO FIND '//TEXT12//'.') 130 KPLIB=LCMDIL(JPLIB,ISO) ! set ISO-th isotope MPCPO=LCMGIL(LPCPO,ICAL) NPCPO=LCMGID(MPCPO,'ISOTOPESLIST') CALL LCMLEL(NPCPO,JSO1,ILENG,ITYLCM) IF(ILENG.NE.0) THEN OPCPO=LCMGIL(NPCPO,JSO1) ! set JSO1-th isotope CALL LCMEQU(OPCPO,KPLIB) ENDIF 180 CONTINUE *---- * PROCESS ADF INFORMATION *---- IF(IDF.GT.0) THEN CALL LCMSIX(MPCPO,'MACROLIB',1) CALL LCMLEN(MPCPO,'ADF',ILONG,ITYLCM) IF(ILONG.NE.0) THEN CALL LCMSIX(MPCPO,'ADF',1) IF(IDF.EQ.1) THEN GAR6(:NGRP,:2)=0.0 CALL LCMGET(MPCPO,'ALBS00',GAR6) DO IGR=1,NGRP ADF2(IBM,IGR,:2)=GAR6(IGR,:2) ENDDO ELSE IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN CALL LCMGET(MPCPO,'NTYPE',NTYPE2) ALLOCATE(HADF2(NTYPE2)) CALL LCMGTC(MPCPO,'HADF',8,NTYPE2,HADF2) IF(NTYPE2.EQ.1) THEN * assign the same ADF to all sides. CALL LCMLEN(MPCPO,HADF2(1),ILONG,ITYLCM) IF(ILONG.NE.NGRP) CALL XABORT('SPHCPO: INVALID ADF LENGT' 1 //'H(1).') CALL LCMGET(MPCPO,HADF2(1),GAR4) DO ITY=1,NTYPE DO IGR=1,NGRP ADF2(IBM,IGR,ITY)=GAR4(IGR) ENDDO ENDDO ELSE IF(NTYPE2.GT.NTYPE) CALL XABORT('SPHCPO: NTYPE OVERFLOW.') DO ITY2=1,NTYPE2 ITY=0 DO JTY=1,NTYPE IF(HADF2(ITY2).EQ.HADF(JTY)) THEN ITY=JTY GO TO 185 ENDIF ENDDO WRITE(HSMG,'(18HSPHCPO: ADF NAMED ,A,11H NOT FOUND.)') 1 TRIM(HADF2(ITY2)) CALL XABORT(HSMG) 185 CALL LCMLEN(MPCPO,HADF2(ITY2),ILONG,ITYLCM) IF(ILONG.NE.NGRP) CALL XABORT('SPHCPO: INVALID ADF LEN' 1 //'GTH(2).') CALL LCMGET(MPCPO,HADF2(ITY2),GAR4) DO IGR=1,NGRP ADF2(IBM,IGR,ITY)=GAR4(IGR) ENDDO ENDDO ENDIF DEALLOCATE(HADF2) ENDIF CALL LCMSIX(MPCPO,' ',2) ENDIF CALL LCMSIX(MPCPO,' ',2) ENDIF 190 CONTINUE *---- * MICROLIB FINALIZATION *---- ISTATE(:NSTATE)=0 ISTATE(1)=NMIL ISTATE(2)=NBISO2 ISTATE(3)=NGRP ISTATE(4)=NL ISTATE(5)=ITRANC ISTATE(7)=1 ISTATE(11)=NDEPL ISTATE(12)=NCOMB+NCOMB2 ISTATE(13)=NED2 ISTATE(14)=NMIL ISTATE(18)=1 ISTATE(19)=NDEL ISTATE(20)=NDFI ISTATE(22)=MAXISO/NMIL ISTATE(25)=NW IF(NBISO2.EQ.0) CALL XABORT('SPHCPO: NBISO2=0.') CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE) CALL LCMPUT(IPLIB,'MIXTURESVOL',NMIL,2,VOLMI2) CALL LCMPUT(IPLIB,'ISOTOPESUSED',3*NBISO2,3,HUSE2) CALL LCMPUT(IPLIB,'ISOTOPERNAME',3*NBISO2,3,HNAM2) CALL LCMPUT(IPLIB,'ISOTOPESDENS',NBISO2,2,DENS2) CALL LCMPUT(IPLIB,'ISOTOPESMIX',NBISO2,1,IMIX2) CALL LCMPUT(IPLIB,'ISOTOPESTYPE',NBISO2,1,ITYP2) CALL LCMPUT(IPLIB,'ISOTOPESTODO',NBISO2,1,ITOD2) CALL LCMPUT(IPLIB,'ISOTOPESVOL',NBISO2,2,VOL2) CALL LCMPUT(IPLIB,'ISOTOPESTEMP',NBISO2,2,TEMP2) IF(NED2.GT.0) CALL LCMPTC(IPLIB,'ADDXSNAME-P0',8,NED2,HVECT2) CALL LCMPUT(IPLIB,'ENERGY',NGRP+1,2,ENER) CALL LCMPUT(IPLIB,'DELTAU',NGRP,2,DELT) IF(IMPX.GT.5) CALL LCMLIB(IPLIB) *---- * RECOVER GENERAL INFORMATION FROM MIXTURE 1 *---- B2=0.0 KPCPO=LCMGIL(JPCPO,1) LPCPO=LCMGID(KPCPO,'CALCULATIONS') MPCPO=LCMGIL(LPCPO,ICAL) CALL LCMLEN(MPCPO,'K-EFFECTIVE',ILENG,ITYLCM) IF(ILENG.EQ.1) THEN CALL LCMGET(MPCPO,'K-EFFECTIVE',FLOTT) CALL LCMPUT(IPLIB,'K-EFFECTIVE',1,2,FLOTT) IF(IMPX.GT.1) THEN WRITE(6,'(22H SPHCPO: K-EFFECTIVE =,1P,E13.6)') FLOTT ENDIF ENDIF CALL LCMLEN(MPCPO,'K-INFINITY',ILENG,ITYLCM) IF(ILENG.EQ.1) THEN CALL LCMGET(MPCPO,'K-INFINITY',FLOTT) CALL LCMPUT(IPLIB,'K-INFINITY',1,2,FLOTT) IF(IMPX.GT.1) THEN WRITE(6,'(21H SPHCPO: K-INFINITY =,1P,E13.6)') FLOTT ENDIF ENDIF CALL LCMLEN(MPCPO,'B2 B1HOM',ILENG,ITYLCM) IF(ILENG.EQ.1) THEN CALL LCMGET(MPCPO,'B2 B1HOM',B2) CALL LCMPUT(IPLIB,'B2 B1HOM',1,2,B2) IF(IMPX.GT.1) THEN WRITE(6,'(13H SPHCPO: B2 =,1P,E14.6)') B2 ENDIF ENDIF *---- * BUILD EMBEDDED MACROLIB *---- ALLOCATE(MUP(NMIL)) MUP(:NMIL)=1 CALL SPHEMB(IPLIB,IPCPO,NGRP,NMIL,MUP,IMPX) DEALLOCATE(MUP) *---- * WRITE ADF INFORMATION *---- IF(IDF.EQ.1) THEN CALL LCMSIX(IPLIB,'MACROLIB',1) CALL LCMSIX(IPLIB,'ADF',1) CALL LCMPUT(IPLIB,'ALBS00',NMIL*NGRP*2,2,ADF2(1,1,1)) CALL LCMSIX(IPLIB,' ',2) CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) ISTATE(12)=IDF CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE) CALL LCMSIX(IPLIB,' ',2) ELSE IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN CALL LCMSIX(IPLIB,'MACROLIB',1) CALL LCMSIX(IPLIB,'ADF',1) DO ITYPE=1,NTYPE CALL LCMPUT(IPLIB,HADF(ITYPE),NMIL*NGRP,2, 1 ADF2(1,1,ITYPE)) ENDDO CALL LCMSIX(IPLIB,' ',2) CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE) ISTATE(12)=IDF CALL LCMPUT(IPLIB,'STATE-VECTOR',NSTATE,1,ISTATE) CALL LCMSIX(IPLIB,' ',2) IF(IMPX.GT.1) THEN DO IBM=1,NMIL WRITE(6,'(/40H SPHCPO: DISCONTINUITY FACTORS - MIXTURE,I5)') 1 IBM DO ITYPE=1,NTYPE WRITE(6,'(1X,A,1H:,1P,(5X,10E12.4))') TRIM(HADF(ITYPE)), 1 (ADF2(IBM,IGR,ITYPE),IGR=1,NGRP) ENDDO ENDDO ENDIF ENDIF *---- * SCRATCH STORAGE DEALLOCATION *---- DEALLOCATE(GAR6,GAR4,ADF2,HADF) DEALLOCATE(VOLMI2,DELT,ENER,VOL2,TEMP2,DENS2,VOL1,TEMP1,DENS1) DEALLOCATE(MILVO,HNAM2,HUSE2,ITOD2,ITYP2,IMIX2,ITOD1,ITYP1,HNAM1, 1 HUSE1) RETURN * 500 FORMAT(8HSPHCPO: ,A,1H(,I4,2H)=,2I5) END