1 files changed, 135 insertions, 0 deletions
diff --git a/Dragon/src/COMDEP.f b/Dragon/src/COMDEP.f
new file mode 100644
index 0000000..26cc19c
--- /dev/null
+++ b/Dragon/src/COMDEP.f
@@ -0,0 +1,135 @@
+*DECK COMDEP
+      SUBROUTINE COMDEP(IPRINT,IPEDIT,IPWORK,ITRES,NISOP,NOMEVO)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Creation of a lumped depletion chain in the multicompo.
+*
+*Copyright:
+* Copyright (C) 2015 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/output
+* IPRINT  print parameter.
+* IPEDIT  pointer to the edition object (L_EDIT signature).
+* IPWORK  pointer to the LCM object where the lumped depletion chain is
+*         written.
+* ITRES   creation index for the macroscopic residual (=0: not created;
+*         =1: not a FP precursor; =2: is a FP precursor).
+* NISOP   number of user-requested particularized isotopes. Equal to
+*         zero if all EDI: isotopes are particularized.
+* NOMEVO  library names of user-requested particularized isotopes.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      INTEGER IPRINT,ITRES,NISOP
+      TYPE(C_PTR) IPEDIT,IPWORK
+      CHARACTER NOMEVO(NISOP)*12
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER (NSTATE=40,MAXBCH=500)
+      INTEGER ISTATE(NSTATE),IHICH(3,MAXBCH)
+      LOGICAL LISO
+      CHARACTER TEXT12*12
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: MYLIS,IHREAC
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHISO,IDREA,IPREA
+      REAL, ALLOCATABLE, DIMENSION(:) :: DDECA
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: DENER,PRATE,YIELD
+*----
+*  RECOVER DEPLETION INFORMATION FROM EDITION OBJECT
+*----
+      CALL LCMSIX(IPEDIT,'DEPL-CHAIN',1)
+      IF(NISOP.GT.0) THEN
+         CALL LCMGET(IPEDIT,'STATE-VECTOR',ISTATE)
+         NBISO=ISTATE(1)
+         IF(ITRES.EQ.2) NBISO=NBISO+1
+         NBFISS=ISTATE(2)
+         NBDPF=ISTATE(3)
+         NSUPS=ISTATE(7)
+         NREAC=ISTATE(8)
+         NFATH=ISTATE(9)
+         MAXFP=NBDPF+30 ! reserve 30 location for lumped fp daughters
+         ALLOCATE(IHISO(3,NBISO),MYLIS(NBISO),IHREAC(2*NREAC),
+     1   IDREA(NREAC,NBISO),DENER(NREAC,NBISO),DDECA(NBISO),
+     2   IPREA(NFATH,NBISO),PRATE(NFATH,NBISO),YIELD(NBFISS,MAXFP))
+         CALL LCMGET(IPEDIT,'ISOTOPESDEPL',IHISO)
+         CALL LCMGET(IPEDIT,'CHARGEWEIGHT',MYLIS)
+         CALL LCMGET(IPEDIT,'DEPLETE-IDEN',IHREAC)
+         CALL LCMGET(IPEDIT,'DEPLETE-REAC',IDREA)
+         CALL LCMGET(IPEDIT,'DEPLETE-ENER',DENER)
+         CALL LCMGET(IPEDIT,'DEPLETE-DECA',DDECA)
+         CALL LCMGET(IPEDIT,'PRODUCE-REAC',IPREA)
+         CALL LCMGET(IPEDIT,'PRODUCE-RATE',PRATE)
+         IF(NBFISS*NBDPF.GT.0) THEN
+            CALL LCMGET(IPEDIT,'FISSIONYIELD',YIELD)
+         ENDIF
+*----
+*  DESCRIBE FISSILE ISOTOPE *MAC*RES
+*----
+         IF(ITRES.EQ.2) THEN
+           IF(IPRINT.GT.1) THEN
+              WRITE(6,'(/42H COMDEP: ADD *MAC*RES RESIDUAL ISOTOPE TO ,
+     1        17HDEPLETION CHAINS.)')
+            ENDIF
+            TEXT12='*MAC*RES'
+            READ(TEXT12,'(3A4)') (IHISO(I0,NBISO),I0=1,3)
+            MYLIS(NBISO)=0
+            IDREA(:,NBISO)=0
+            DENER(:,NBISO)=0.0
+            IDREA(1,NBISO)=4
+            DDECA(NBISO)=0.0
+            IPREA(:,NBISO)=0
+            PRATE(:,NBISO)=0.0
+         ENDIF
+*----
+*  CREATE LUMPED DEPLETION CHAIN
+*----
+         CALL LCMSIX(IPWORK,'DEPL-CHAIN',1)
+         LISO=.FALSE.
+         NBCH=0
+         DO 20 ISO=1,NBISO
+         WRITE(TEXT12,'(3A4)') (IHISO(I0,ISO),I0=1,3)
+         DO JSO=1,NISOP
+           IF((TEXT12.EQ.NOMEVO(JSO)).AND.(TEXT12.NE.'*MAC*RES')) THEN
+             NBCH=NBCH+1
+             IF(NBCH.GT.MAXBCH) CALL XABORT('COMDEP: MAXBCH OVERFLOW.')
+             READ(TEXT12,'(3A4)') (IHICH(I0,NBCH),I0=1,3)
+             GO TO 20
+           ENDIF
+         ENDDO
+         IF((TEXT12.EQ.'*MAC*RES').AND.(ITRES.EQ.2)) THEN
+           NBCH=NBCH+1
+           IF(NBCH.GT.MAXBCH) CALL XABORT('COMDEP: MAXBCH OVERFLOW.')
+           READ(TEXT12,'(3A4)') (IHICH(I0,NBCH),I0=1,3)
+         ENDIF
+   20    CONTINUE
+         CALL EDILUM(IPRINT,IPWORK,MAXFP,NBISO,NBFISS,NBDPF,NSUPS,
+     1   NREAC,NFATH,NBCH,IHICH,IHISO,MYLIS,IHREAC,IDREA,DENER,DDECA,
+     2   IPREA,PRATE,YIELD,LISO,NBFISS,NBCH)
+         DEALLOCATE(YIELD,PRATE,IPREA,DDECA,DENER,IDREA,IHREAC,MYLIS,
+     1   IHISO)
+      ELSE
+*----
+*  RECOVER THE DEPLETION CHAIN WITHOUT LUMPING
+*----
+         CALL LCMSIX(IPWORK,'DEPL-CHAIN',1)
+         CALL LCMEQU(IPEDIT,IPWORK)
+      ENDIF
+      CALL LCMSIX(IPWORK,' ',2)
+      CALL LCMSIX(IPEDIT,' ',2)
+      RETURN
+      END