1 files changed, 150 insertions, 0 deletions
diff --git a/Donjon/src/FPSOUT.f b/Donjon/src/FPSOUT.f
new file mode 100644
index 0000000..5d78203
--- /dev/null
+++ b/Donjon/src/FPSOUT.f
@@ -0,0 +1,150 @@
+*DECK FPSOUT
+      SUBROUTINE FPSOUT(IPMAC,IPRINT,NG,NMIL,NFIS,ILEAKS,TEXT9,OUTG)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Compute the leakage rate in each energy group
+*
+*Copyright:
+* Copyright (C) 2019 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
+* IPMAC   pointer to the macrolib structure.
+* IPRINT  print parameter
+* NG      number of energy groups.
+* NMIL    number of material mixtures.
+* NFIS    number of fissile isotopes.
+* ILEAKS  type of leakage calculation =0: no leakage; =1: homogeneous
+*         leakage (Diffon).
+* TEXT9   type of calculation ('REFERENCE' or 'MACRO').
+*
+*Parameters: output
+* OUTG    leakage rates.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPMAC
+      INTEGER IPRINT,NG,NMIL,NFIS,ILEAKS
+      CHARACTER TEXT9*9
+      REAL OUTG(NG)
+*----
+*  LOCAL VARIABLES
+*----
+      TYPE(C_PTR) JPMAC,KPMAC
+      CHARACTER HSMG*131
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: IJJ,NJJ,IPOS
+      REAL, ALLOCATABLE, DIMENSION(:) :: GAR,WORK,DIFHOM,DIFF
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: PHI,NUF
+      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: CHI,RHS,LHS
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(PHI(NMIL,NG),RHS(NMIL,NG,NG),LHS(NMIL,NG,NG))
+      ALLOCATE(IJJ(NMIL),NJJ(NMIL),IPOS(NMIL),GAR(NMIL),WORK(NMIL*NG),
+     > CHI(NMIL,NFIS,NG),NUF(NMIL,NFIS),DIFHOM(NG),DIFF(NMIL))
+*----
+*  COMPUTE THE ACTUAL AND REFERENCE REACTION RATE MATRICES
+*----
+      CALL LCMGET(IPMAC,'K-EFFECTIVE',ZKEFF)
+      IF(IPRINT.GT.1) WRITE(6,120) TEXT9,ZKEFF
+      CALL LCMLEN(IPMAC,'B2  B1HOM',ILCMLN,ITYLCM)
+      IF(ILCMLN.EQ.1) THEN
+        CALL LCMGET(IPMAC,'B2  B1HOM',B2)
+      ELSE
+        B2=0.0
+      ENDIF
+      IF((ILEAKS.EQ.1).AND.(IPRINT.GT.1)) THEN
+        WRITE(6,'(/9H FPSOUT: ,A,4H B2=,1P,E12.4)') TEXT9,B2
+      ENDIF
+      RHS(:NMIL,:NG,:NG)=0.0
+      LHS(:NMIL,:NG,:NG)=0.0
+      JPMAC=LCMGID(IPMAC,'GROUP')
+      DO IG=1,NG
+        KPMAC=LCMGIL(JPMAC,IG)
+        CALL LCMGET(KPMAC,'CHI',CHI(1,1,IG))
+        CALL LCMLEN(KPMAC,'FLUX-INTG',ILG,ITYLCM)
+        IF(ILG.NE.NMIL) CALL XABORT('FPSOUT: MISSING REFERENCE FLUX.')
+        CALL LCMGET(KPMAC,'FLUX-INTG',PHI(1,IG))
+      ENDDO
+      DO IG=1,NG
+        KPMAC=LCMGIL(JPMAC,IG)
+        IF(ILEAKS.EQ.1) THEN
+          CALL LCMLEN(KPMAC,'DIFF',ILCMLN,ITYLCM)
+          IF(ILCMLN.GT.0) THEN
+            CALL LCMGET(KPMAC,'DIFF',DIFF)
+          ELSE
+            CALL LCMGET(IPMAC,'DIFHOMB1HOM',DIFHOM)
+            DO IBM=1,NMIL
+              DIFF(IBM)=DIFHOM(IG)
+            ENDDO
+          ENDIF
+        ELSE
+          DIFF(:NMIL)=0.0
+        ENDIF
+        CALL LCMGET(KPMAC,'NTOT0',GAR)
+        CALL LCMGET(KPMAC,'SCAT00',WORK)
+        CALL LCMGET(KPMAC,'NJJS00',NJJ)
+        CALL LCMGET(KPMAC,'IJJS00',IJJ)
+        CALL LCMGET(KPMAC,'IPOS00',IPOS)
+        DO IBM=1,NMIL
+          IPOSDE=IPOS(IBM)
+          DO JG=IJJ(IBM),IJJ(IBM)-NJJ(IBM)+1,-1
+*           IG <-- JG
+            RHS(IBM,IG,JG)=RHS(IBM,IG,JG)-WORK(IPOSDE)*PHI(IBM,JG)
+            IPOSDE=IPOSDE+1
+          ENDDO
+          RHS(IBM,IG,IG)=RHS(IBM,IG,IG)+(GAR(IBM)+B2*DIFF(IBM))*
+     >    PHI(IBM,IG)
+        ENDDO
+        CALL LCMGET(KPMAC,'NUSIGF',NUF)
+        DO IBM=1,NMIL
+          DO IFIS=1,NFIS
+            DO JG=1,NG
+              LHS(IBM,JG,IG)=LHS(IBM,JG,IG)+CHI(IBM,IFIS,JG)*
+     >        NUF(IBM,IFIS)*PHI(IBM,IG)
+            ENDDO
+          ENDDO
+        ENDDO
+      ENDDO
+*----
+*  COMPUTE THE ACTUAL AND REFERENCE ABSORPTION AND FISSION RATES
+*----
+      DO IG=1,NG
+        OUTG(IG)=0.0
+        DO IBM=1,NMIL
+          OUTG(IG)=OUTG(IG)+SUM(LHS(IBM,IG,:NG))/ZKEFF-
+     1    SUM(RHS(IBM,IG,:NG))
+        ENDDO
+        IF(OUTG(IG).LT.-1.0E-6) THEN
+          WRITE(HSMG,'(21HFPSOUT: INCONSISTENT ,A,17H LEAKAGE IN GROUP,
+     1    I4,7H. LEAK=,1P,E13.4)') TEXT9,IG,OUTG(IG)
+          CALL XABORT(HSMG)
+        ENDIF
+        IF(IPRINT.GT.1) WRITE(6,130) IG,TEXT9,OUTG(IG)
+      ENDDO
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(DIFF,DIFHOM,NUF,CHI,WORK,GAR,IPOS,NJJ,IJJ)
+      DEALLOCATE(LHS,RHS,PHI)
+      RETURN
+*
+  120 FORMAT(/9H FPSOUT: ,A,33H EFFECTIVE MULTIPLICATION FACTOR=,1P,
+     1 E12.4)
+  130 FORMAT(/8H FPSOUT:,5X,6HGROUP=,I4,1X,A,9H LEAKAGE=,1P,E12.4)
+      END