Initial commit from Polytechnique Montreal

1 files changed, 213 insertions, 0 deletions

diff --git a/Dragon/src/SAPCAL.f b/Dragon/src/SAPCAL.f
new file mode 100644
index 0000000..5cb8f69
--- /dev/null
+++ b/Dragon/src/SAPCAL.f
@@ -0,0 +1,213 @@
+*DECK SAPCAL
+      SUBROUTINE SAPCAL(IMPX,IPSAP,IPDEPL,IPEDIT,LCRON)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Store the results of an elementary calculation in the Saphyb.
+*
+*Copyright:
+* Copyright (C) 2007 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
+* IMPX    print parameter.
+* IPSAP   pointer to the Saphyb.
+* IPDEPL  pointer to the burnup object (L_BURNUP signature).
+* IPEDIT  pointer to the edition object (L_EDIT signature).
+* LCRON   flag set to .TRUE. to put kinetics data into divers directory.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPSAP,IPDEPL,IPEDIT,IPSPH
+      INTEGER IMPX
+      LOGICAL LCRON
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER (NDIMSA=50,NSTATE=40,MAXMAC=2)
+      INTEGER IDATA(NDIMSA),IPAR(NSTATE),TYPMAC(MAXMAC)
+      REAL BIRRAD(2)
+      CHARACTER CDIRO*12,HSMG*131,TEXT20*20
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: HMIX,IWORKT,IWORKR
+      REAL, ALLOCATABLE, DIMENSION(:) :: VOL,REGFLX
+*
+      CALL LCMGTC(IPEDIT,'LAST-EDIT',12,CDIRO)
+      CALL LCMSIX(IPEDIT,CDIRO,1)
+      CALL LCMLEN(IPEDIT,'STATE-VECTOR',ILONG,ITYLCM)
+      IF(ILONG.NE.0) THEN
+         CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR)
+         NBISO=IPAR(2)
+         NED=IPAR(13)
+         NPRC=IPAR(19)
+         NDFI=IPAR(20)
+      ELSE
+         NBISO=0
+         NDFI=0
+      ENDIF
+      CALL LCMSIX(IPEDIT,'MACROLIB',1)
+      CALL LCMGET(IPEDIT,'STATE-VECTOR',IPAR)
+      NG=IPAR(1)
+      NMIL=IPAR(2)
+      NL=IPAR(3)
+      IF(IPAR(4).GT.1) CALL XABORT('SAPCAL: CANNOT PROCESS MULTIPLE FI'
+     1 //'SSION SPECTRA.')
+      NED=IPAR(5)
+      ITRANC=IPAR(6)
+      NPRC=IPAR(7)
+      IDF=IPAR(12)
+      CALL LCMLEN(IPEDIT,'SPH',ILEN,ITYLCM)
+      IF(ILEN.NE.0) THEN
+         IPSPH=LCMGID(IPEDIT,'SPH')
+         CALL LCMGET(IPSPH,'STATE-VECTOR',IPAR)
+         IMC=IPAR(6)
+      ELSE
+         IMC=0
+      ENDIF
+*
+      CALL LCMGET(IPSAP,'DIMSAP',IDATA)
+      NREA=IDATA(4)
+      NISO=IDATA(5)
+      NMAC=IDATA(6)
+      NADRX=IDATA(18)
+      ICAL=IDATA(19)+1
+      IF(IDATA(19).EQ.0) THEN
+*        COMPLETE DIMSAP AND CONTENU DIRECTORY.
+         IF(IDATA(7).EQ.0) THEN
+            IDATA(7)=NMIL
+            ALLOCATE(HMIX(5*NMIL))
+            DO 10 IMIL=1,NMIL
+            TEXT20=' '
+            WRITE(TEXT20,'(3HMIX,I5.5)') IMIL
+            READ(TEXT20,'(5A4)') (HMIX((IMIL-1)*5+I0),I0=1,5)
+   10       CONTINUE
+            CALL LCMSIX(IPSAP,'geom',1)
+            CALL LCMPUT(IPSAP,'NOMMIL',5*NMIL,3,HMIX)
+            CALL LCMSIX(IPSAP,' ',2)
+            DEALLOCATE(HMIX)
+         ELSE IF(NMIL.NE.IDATA(7)) THEN
+            WRITE(HSMG,'(42HSAPCAL: ELEMENTARY CALCULATION WITH AN INV,
+     1      22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMIL,IDATA(7)
+            CALL XABORT(HSMG)
+         ENDIF
+         IDATA(20)=NG
+         IDATA(31)=NPRC
+         CALL LCMSIX(IPSAP,'contenu',1)
+         ALLOCATE(IWORKT(NMIL),IWORKR(NMIL))
+         IWORKT(:NMIL)=0
+         IWORKR(:NMIL)=0
+         IF(NMAC.GT.0) CALL LCMGET(IPSAP,'TYPMAC',TYPMAC)
+         DO 20 IMAC=1,NMAC
+         IF(TYPMAC(IMAC).EQ.1) IWORKT(:NMIL)=IMAC
+         IF(TYPMAC(IMAC).EQ.2) IWORKR(:NMIL)=IMAC
+   20    CONTINUE
+         CALL LCMPUT(IPSAP,'TOTMAC',NMIL,1,IWORKT)
+         CALL LCMPUT(IPSAP,'RESMAC',NMIL,1,IWORKR)
+         DEALLOCATE(IWORKR,IWORKT)
+         CALL LCMSIX(IPSAP,' ',2)
+*
+*        RECOVER MIXTURE VOLUMES.
+         ALLOCATE(VOL(NMIL))
+         CALL LCMGET(IPEDIT,'VOLUME',VOL)
+         CALL LCMSIX(IPSAP,'geom',1)
+         CALL LCMPUT(IPSAP,'XVOLMT',NMIL,2,VOL)
+         DEALLOCATE(VOL)
+         CALL LCMSIX(IPSAP,' ',2)
+      ELSE
+         IF(NMIL.NE.IDATA(7)) THEN
+            WRITE(HSMG,'(42HSAPCAL: ELEMENTARY CALCULATION WITH AN INV,
+     1      22HALIB NB. OF MIXTURES =,I7,3H NE,I7,1H.)') NMIL,IDATA(7)
+            CALL XABORT(HSMG)
+         ELSE IF(NG.NE.IDATA(20)) THEN
+            WRITE(HSMG,'(42HSAPCAL: ELEMENTARY CALCULATION WITH AN INV,
+     1      20HALIB NB. OF GROUPS =,I7,3H NE,I7,1H.)') NG,IDATA(20)
+            CALL XABORT(HSMG)
+         ENDIF
+      ENDIF
+      CALL LCMSIX(IPEDIT,' ',2)
+*----
+*  RECOVER THE FLUX NORMALIZATION FACTOR.
+*----
+      IF(C_ASSOCIATED(IPDEPL)) THEN
+         CALL LCMGET(IPDEPL,'BURNUP-IRRAD',BIRRAD)
+         BURN=BIRRAD(1)
+         CALL LCMLEN(IPDEPL,'FLUX-NORM',ILONG,ITYLCM)
+         IF(ILONG.EQ.0) THEN
+            WRITE(HSMG,'(40HSAPCAL: THE ''FLUX-NORM'' RECORD IS NOT SE,
+     1      20HT FOR BURNUP STEP AT,E12.5,14H MW-DAY/TONNE.)') BURN
+            CALL XABORT(HSMG)
+         ENDIF
+         CALL LCMGET(IPDEPL,'FLUX-NORM',FNORM)
+         IF(IMPX.GT.0) WRITE(6,100) FNORM,BURN
+      ELSE
+         FNORM=1.0
+         IF(IMPX.GT.0) WRITE(6,110)
+      ENDIF
+*----
+*  RECOVER THE CROSS SECTIONS.
+*----
+      ALLOCATE(REGFLX(NG))
+      MAXRDA=(NREA*NG+NL*NG+NL*NG*NG)*(NISO+NMAC)
+      MAXIDA=(2*NG+7)*NL*(NISO+NMAC)
+      CALL SAPCA2(IPSAP,IPEDIT,NREA,NISO,NMAC,NADRX,NED,NPRC,NG,NL,
+     1 ITRANC,IMC,NMIL,NBISO,ICAL,MAXRDA,MAXIDA,FNORM,LCRON,NISOTS,
+     2 NMILNR,NISFS,NISPS,NISYS,REGFLX)
+*----
+*  RECOVER DISCONTINUITY FACTOR INFORMATION.
+*----
+      IF((IDF.EQ.2).OR.(IDF.EQ.3)) THEN
+        CALL SAPIDF(IPSAP,IPEDIT,NG,NMIL,ICAL,IDF,FNORM,REGFLX)
+      ENDIF
+      DEALLOCATE(REGFLX)
+*----
+*  COMPLETE DIMSAP.
+*----
+      IDATA(18)=NADRX
+      IF(IDATA(21).EQ.0) THEN
+         IDATA(21)=NISYS
+         IDATA(32)=NISOTS
+         IDATA(33)=NMILNR
+      ELSE
+         IF(NISYS.NE.IDATA(21)) THEN
+            WRITE(HSMG,'(42HSAPCAL: ELEMENTARY CALCULATION WITH AN INV,
+     1      21HALIB VALUE OF NISOY =,I7,3H NE,I7,1H.)') NISYS,IDATA(21)
+            CALL XABORT(HSMG)
+         ELSE IF(NISOTS.NE.IDATA(32)) THEN
+            WRITE(HSMG,'(43HSAPCAL: ELEMENTARY CALCULATION WITH AN INVA,
+     1      21HLIB NB. OF ISOTOPES =,I7,3H NE,I7,1H.)') NISOTS,IDATA(32)
+            CALL XABORT(HSMG)
+         ELSE IF(NMILNR.NE.IDATA(33)) THEN
+            WRITE(HSMG,'(43HSAPCAL: ELEMENTARY CALCULATION WITH AN INVA,
+     1      47HLIB NB. OF MIXTURES WITH DELAYED NEUTRON DATA =,I7,3H NE,
+     2      I7,1H.)') NMILNR,IDATA(33)
+            CALL XABORT(HSMG)
+         ENDIF
+      ENDIF
+*----
+*  RECOVER THE FISSION YIELDS.
+*----
+      IF(NISYS.GT.0) THEN
+         CALL SAPGEY(IPSAP,IPEDIT,NISO,NMAC,NG,NMIL,NBISO,ICAL,NDFI,
+     1   NISFS,NISPS,NISYS)
+      ENDIF
+*
+      CALL LCMSIX(IPEDIT,' ',2)
+      CALL LCMPUT(IPSAP,'DIMSAP',NDIMSA,1,IDATA)
+      RETURN
+*
+  100 FORMAT(45H SAPCAL: NORMALIZE THE FLUX WITH THE FACTOR =,1P,E12.5,
+     1 26H TAKEN FROM BURNUP STEP AT,E12.5,14H MW-DAY/TONNE.)
+  110 FORMAT(36H SAPCAL: THE FLUX IS NOT NORMALIZED.)
+      END