Initial commit from Polytechnique Montreal

1 files changed, 137 insertions, 0 deletions

diff --git a/Dragon/src/SPHEMB.f b/Dragon/src/SPHEMB.f
new file mode 100644
index 0000000..a635a7a
--- /dev/null
+++ b/Dragon/src/SPHEMB.f
@@ -0,0 +1,137 @@
+*DECK SPHEMB
+      SUBROUTINE SPHEMB(IPLIB,IPCPO,NGRP,NMIX,MIXUPD,IMPX)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Build embedded macrolib and recover depletion data from the
+* multicompo.
+*
+*Copyright:
+* Copyright (C) 2008 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, R. Chambon
+*
+*Parameters: input/output
+* IPLIB   address of the microlib LCM object.
+* IPCPO   address of the multicompo object.
+* NGRP    number of energy groups.
+* NMIX    maximum number of material mixtures in the microlib.
+* MIXUPD  tag for mixture which will be updated.
+* IMPX    print parameter (equal to zero for no print).
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPLIB,IPCPO
+      INTEGER NGRP,NMIX
+      INTEGER MIXUPD(NMIX)
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER (NSTATE=40,IOUT=6)
+      CHARACTER HSMG*131
+      INTEGER ISTATE(NSTATE),IST1(NSTATE),IST2(NSTATE)
+      REAL TMPDAY(3)
+      LOGICAL, ALLOCATABLE, DIMENSION(:) :: MASK,MASKL
+      INTEGER, POINTER, DIMENSION(:) :: ISONA,ISOMI
+      REAL, POINTER, DIMENSION(:) :: DENIS
+      TYPE(C_PTR) ISONA_PTR,ISOMI_PTR,DENIS_PTR
+*----
+*  RECOVER THE DEPLETION CHAIN
+*----
+      CALL LCMLEN(IPLIB,'DEPL-CHAIN',ILENG1,ITYLCM)
+      CALL LCMLEN(IPCPO,'DEPL-CHAIN',ILENG2,ITYLCM)
+      IF((ILENG1.NE.0).AND.(ILENG2.NE.0)) THEN
+        CALL LCMSIX(IPCPO,'DEPL-CHAIN',1)
+        CALL LCMGET(IPCPO,'STATE-VECTOR',IST1)
+        CALL LCMSIX(IPCPO,' ',2)
+        CALL LCMSIX(IPLIB,'DEPL-CHAIN',1)
+        CALL LCMGET(IPLIB,'STATE-VECTOR',IST2)
+        CALL LCMSIX(IPLIB,' ',2)
+        DO 100 I=1,NSTATE
+        IF(IST1(I).NE.IST2(I)) THEN
+          WRITE(HSMG,'(40HSPHEMB: INVALID STATE-VECTOR COMPONENT (,I2,
+     1    36H) FOR DEPL-CHAIN DATA IN MULTICOMPO ,1H.)') I
+          CALL XABORT(HSMG)
+        ENDIF
+  100   CONTINUE
+      ELSE IF((ILENG1.EQ.0).AND.(ILENG2.NE.0)) THEN
+        CALL LCMSIX(IPCPO,'DEPL-CHAIN',1)
+        CALL LCMSIX(IPLIB,'DEPL-CHAIN',1)
+        CALL LCMEQU(IPCPO,IPLIB)
+        CALL LCMSIX(IPLIB,' ',2)
+        CALL LCMSIX(IPCPO,' ',2)
+      ENDIF
+*----
+*  COMPUTE THE MACROSCOPIC X-SECTIONS
+*----
+      CALL LCMGET(IPLIB,'STATE-VECTOR',ISTATE)
+      MAXMIX=ISTATE(1)
+      IF(MAXMIX.NE.NMIX) CALL XABORT('SPHEMB: INVALID NMIX.')
+      NBISO=ISTATE(2)
+      ALLOCATE(MASK(MAXMIX),MASKL(NGRP))
+      CALL LCMGPD(IPLIB,'ISOTOPESUSED',ISONA_PTR)
+      CALL LCMGPD(IPLIB,'ISOTOPESMIX',ISOMI_PTR)
+      CALL LCMGPD(IPLIB,'ISOTOPESDENS',DENIS_PTR)
+      CALL C_F_POINTER(ISONA_PTR,ISONA,(/ NBISO /))
+      CALL C_F_POINTER(ISOMI_PTR,ISOMI,(/ NBISO /))
+      CALL C_F_POINTER(DENIS_PTR,DENIS,(/ NBISO /))
+      MASK(:MAXMIX)=.FALSE.
+      MASKL(:NGRP)=.TRUE.
+      DO 110 ISOT=1,NBISO
+        IBM=ISOMI(ISOT)
+        IF(IBM.GT.0) THEN
+          IF(MIXUPD(IBM).NE.0) MASK(IBM)=.TRUE.
+        ENDIF
+  110 CONTINUE
+      ITSTMP=0
+      TMPDAY(1)=0.0
+      TMPDAY(2)=0.0
+      TMPDAY(3)=0.0
+      CALL LIBMIX(IPLIB,MAXMIX,NGRP,NBISO,ISONA,ISOMI,DENIS,MASK,MASKL,
+     1 ITSTMP,TMPDAY)
+      DEALLOCATE(MASKL,MASK)
+*----
+*  RECOVER GENERAL INFORMATION FROM MICROLIB
+*----
+      B2=0.0
+      CALL LCMLEN(IPLIB,'K-EFFECTIVE',ILENG,ITYLCM)
+      IF(ILENG.EQ.1) THEN
+        CALL LCMGET(IPLIB,'K-EFFECTIVE',FLOTT)
+        CALL LCMSIX(IPLIB,'MACROLIB',1)
+        CALL LCMPUT(IPLIB,'K-EFFECTIVE',1,2,FLOTT)
+        CALL LCMSIX(IPLIB,' ',2)
+        IF(IMPX.GT.1) THEN
+          WRITE(6,'(22H SPHCPO: K-EFFECTIVE =,1P,E13.6)') FLOTT
+        ENDIF
+      ENDIF
+      CALL LCMLEN(IPLIB,'K-INFINITY',ILENG,ITYLCM)
+      IF(ILENG.EQ.1) THEN
+        CALL LCMGET(IPLIB,'K-INFINITY',FLOTT)
+        CALL LCMSIX(IPLIB,'MACROLIB',1)
+        CALL LCMPUT(IPLIB,'K-INFINITY',1,2,FLOTT)
+        CALL LCMSIX(IPLIB,' ',2)
+        IF(IMPX.GT.1) THEN
+          WRITE(6,'(21H SPHCPO: K-INFINITY =,1P,E13.6)') FLOTT
+        ENDIF
+      ENDIF
+      CALL LCMLEN(IPLIB,'B2  B1HOM',ILENG,ITYLCM)
+      IF(ILENG.EQ.1) THEN
+        CALL LCMGET(IPLIB,'B2  B1HOM',B2)
+        CALL LCMSIX(IPLIB,'MACROLIB',1)
+        CALL LCMPUT(IPLIB,'B2  B1HOM',1,2,B2)
+        CALL LCMSIX(IPLIB,' ',2)
+        IF(IMPX.GT.1) THEN
+          WRITE(6,'(13H SPHCPO: B2 =,1P,E14.6)') B2
+        ENDIF
+      ENDIF
+      RETURN
+      END