Initial commit from Polytechnique Montreal

1 files changed, 148 insertions, 0 deletions

diff --git a/Donjon/src/DETDRV.f b/Donjon/src/DETDRV.f
new file mode 100644
index 0000000..2a22b4d
--- /dev/null
+++ b/Donjon/src/DETDRV.f
@@ -0,0 +1,148 @@
+*DECK DETDRV
+      SUBROUTINE DETDRV(IPDET,NGRP,IPRT,LHEX,NDETOT,LENTRY)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+*  Driver for module DETINI:
+*
+*Copyright:
+* Copyright (C) 2010 Ecole Polytechnique de Montreal.
+*
+*Author(s): 
+* J. Koclas, E. Varin, M. Guyot
+*
+*Parameters: input/output
+* IPDET   pointer to the L_DETECT object.
+* NGRP    number of energy groups
+* IPRT    printing flag
+* LHEX    =.TRUE. if it is an hexagonal geometry
+* NDETOT  total number of detectors
+* LENTRY  =.TRUE. if the L_DETECT object is updated
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      IMPLICIT NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPDET
+      INTEGER  NGRP,IPRT,NDETOT
+      LOGICAL  LHEX,LENTRY
+*----
+*  LOCAL VARIABLES
+*----
+      CHARACTER TEXT*12,TYPE*12
+      INTEGER ITYP,NITMA,NDETEC,NREP,I,INFO(2)
+      REAL FLOT
+      DOUBLE PRECISION DFLOT
+      REAL, ALLOCATABLE, DIMENSION(:) :: SPEC,CST,FRACT
+*----
+*  READING INFORMATION LINKED TO DETECTOR TYPE
+*----
+      CALL REDGET(ITYP,NITMA,FLOT,TYPE,DFLOT)
+      IF (ITYP.NE.3) CALL XABORT('@DETDRV: CHARACTER DATA'
+     +  //' EXPECTED(1)')
+      CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+      IF ((ITYP.NE.3).OR.(TEXT.NE.'INFO')) CALL XABORT('@DETINI:'
+     +  //' CHARACTER INFO EXPECTED')
+      CALL REDGET(ITYP,NDETEC,FLOT,TEXT,DFLOT)
+      IF (ITYP.NE.1) CALL XABORT('@DETDRV: INTEGER DATA EXPECTED(1)')
+      CALL REDGET(ITYP,NREP,FLOT,TEXT,DFLOT)
+      IF(NREP.LT.2)CALL XABORT('@DETDRV: AT LEAST TWO RESPONSES')
+*----
+*  READING INFORMATION LINKED TO ENERGY SPECTRAL
+*----
+      IF(NGRP.EQ.0)CALL XABORT('@DETDRV: NUMBER OF GROUPS REQUIRED')
+      ALLOCATE(SPEC(NGRP))
+      CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+      IF (ITYP.NE.3) CALL XABORT('@DETDRV: CHARACTER DATA'
+     +  //' EXPECTED(2)')
+      IF(TEXT.EQ.'SPECTRAL') THEN
+        DO 10 I=1,NGRP
+          CALL REDGET(ITYP,NITMA,SPEC(I),TEXT,DFLOT)
+          IF (ITYP.NE.2) CALL XABORT('@DETDRV: REAL DATA EXPECTED '
+     +       //'FOR SPECTRAL')
+  10    CONTINUE
+      ELSEIF(TEXT.EQ.'DEFAULT')THEN
+        DO 20 I=1,NGRP-1
+         SPEC(I) = 0.0
+  20    CONTINUE
+        SPEC(NGRP) = 1.0
+        WRITE(6,*) '**** WARINING **** ENERGY SPECTRAL INITIALIZED '
+     +     //'TO 1.0 IN THE HIGHEST GROUP ONLY '
+      ELSE 
+        CALL XABORT('@DETDRV: KEYWORDS FOR SPECTRAL EXPECTED')
+      ENDIF
+*----
+*  READING INFORMATION LINKED TO DELAY CONSTANT AND FRACTION READING
+*----
+      IF(TYPE(1:5).EQ.'PLATN') THEN
+        IF(NREP.LE.2)CALL XABORT('@DETDRV: MORE THAN TWO RESPONSES'
+     +         //' MUST BE SPECIFIED')
+        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT) 
+        IF (ITYP.NE.3) CALL XABORT('@DETDRV: CHARACTER DATA'
+     +    //' EXPECTED(3)')
+        IF(TEXT.EQ.'INVCONST') THEN
+          ALLOCATE(CST(NREP-2))
+          DO 40 I=1,NREP-2
+            CALL REDGET(ITYP,NITMA,CST(I),TEXT,DFLOT)
+            IF(ITYP.NE.2) CALL XABORT('@DETDRV: REAL DATA EXPECTED '
+     +         //'FOR TIME CONSTANTS') 
+   40     CONTINUE
+          CALL LCMSIX(IPDET,' ',0)
+          CALL LCMSIX(IPDET,TYPE,1)
+          CALL LCMPUT(IPDET,'INV-CONST',NREP-2,2,CST)
+          CALL LCMSIX(IPDET,' ',0)
+          DEALLOCATE(CST)
+        ELSE
+           CALL XABORT('@DETDRV: KEYWORD INVCONST EXPECTED FOR'
+     +           //' PLATINIUM DETECTORS')
+        ENDIF
+        CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
+        IF (ITYP.NE.3) CALL XABORT('@DETDRV: CHARACTER DATA'
+     +    //' EXPECTED(4)')
+        IF(TEXT.EQ.'FRACTION') THEN
+          ALLOCATE(FRACT(NREP-1))
+          DO 50 I=1,NREP-1
+            CALL REDGET(ITYP,NITMA,FRACT(I),TEXT,DFLOT)
+            IF (ITYP.NE.2) CALL XABORT('@DETDRV: REAL DATA EXPECTED'
+     +       //' FOR FRACTION')
+  50      CONTINUE
+          CALL LCMSIX(IPDET,' ',0)
+          CALL LCMSIX(IPDET,TYPE,1)
+          CALL LCMPUT(IPDET,'FRACTION',NREP-1,2,FRACT)
+          CALL LCMSIX(IPDET,' ',0)
+          DEALLOCATE(FRACT)
+        ELSE
+           CALL XABORT('@DETDRV: KEYWORD FRACTION EXPECTED FOR'
+     +           //' PLATINIUM DETECTORS')
+        ENDIF
+      ENDIF
+      
+      DO 30 I=1,NDETEC
+        CALL DETREAD(IPDET,TYPE,NREP,IPRT,LHEX)
+  30  CONTINUE
+*----
+*  STORAGE OF INFORMATION
+*----
+      CALL LCMSIX(IPDET,' ',0)
+      CALL LCMSIX(IPDET,TYPE,1)
+      IF (.NOT.LENTRY) THEN
+        INFO(1)=NDETEC
+        INFO(2)=NREP
+      ELSE
+        CALL LCMGET(IPDET,'INFORMATION',INFO)
+        INFO(1) = INFO(1) + NDETEC
+        IF (NREP.NE.INFO(2))
+     +   CALL XABORT('@DETDRV: RESPONS NUMBER INCONSISTENT WITH '//
+     +   ' THE PREVIOUS VALUE')
+      ENDIF
+      CALL LCMPUT(IPDET,'INFORMATION',2,1,INFO)
+      CALL LCMPUT(IPDET,'SPECTRAL',NGRP,2,SPEC)
+      CALL LCMSIX(IPDET,' ',0)
+      NDETOT = NDETOT + NDETEC
+      DEALLOCATE(SPEC)
+      RETURN
+      END