From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001
From: stainer_t <thomas.stainer@oecd-nea.org>
Date: Mon, 8 Sep 2025 13:48:49 +0200
Subject: Initial commit from Polytechnique Montreal

---
 Dragon/src/PIJRDG.f | 91 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 91 insertions(+)
 create mode 100644 Dragon/src/PIJRDG.f

(limited to 'Dragon/src/PIJRDG.f')

diff --git a/Dragon/src/PIJRDG.f b/Dragon/src/PIJRDG.f
new file mode 100644
index 0000000..bb6c0a5
--- /dev/null
+++ b/Dragon/src/PIJRDG.f
@@ -0,0 +1,91 @@
+*DECK PIJRDG
+      SUBROUTINE PIJRDG(IPRT,NREG,NSOUT,SIGTAL,PROB)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Diagonal normalization of collision probs (CP).
+*
+*Copyright:
+* Copyright (C) 1991 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): R. Roy
+*
+*Parameters: input
+* IPRT    print level.
+* NREG    number of zones for geometry.
+* NSOUT   number of surfaces for geometry.
+* SIGTAL  albedo-sigt vector.
+*
+*Parameters: input/output
+* PROB    CP matrix for all types.
+*
+*References:
+* R. Roy and G. Marleau,
+* Normalization Techniques for CP Matrices,
+* CONF/PHYSOR-90, Marseille/France, V 2, P IX-40 (1990).
+*-----------------------------------------------------------------------
+*
+      IMPLICIT   NONE
+      INTEGER    IPRT,NREG,NSOUT,IR,JR,IPRB,IPRF,IUNK,JUNK,IVOL
+      REAL       SIGTAL(-NSOUT:NREG)
+      INTEGER    IUNOUT,IPRINT
+      PARAMETER (IUNOUT=6, IPRINT=4)
+      DOUBLE PRECISION PROB(*),BILAN
+      IPRB= 0
+      IUNK= 0
+      IVOL= NSOUT*(NSOUT+1)/2
+*
+*     RENORMALIZE ALL DIAGONAL ELEMENTS OF MATRIX *PROB*
+      IF( IPRT.GE.IPRINT )THEN
+         WRITE(IUNOUT,9000) 'PIJRDG'
+      ENDIF
+      DO 100 IR = -NSOUT, NREG
+         IUNK= IUNK+1
+         BILAN=0.0
+         DO 10 JR= -NSOUT, IR-1
+            IPRB= IPRB+1
+            IF( JR.LT.0.OR.SIGTAL(JR).GT.0.0 )THEN
+               BILAN=BILAN + PROB(IPRB)
+            ENDIF
+   10    CONTINUE
+         IPRB= IPRB+1
+         IPRF= IPRB
+         JUNK= IUNK
+         DO 20 JR=  IR+1 , NREG
+            IPRF= IPRF+JUNK
+            JUNK= JUNK+1
+            IF( JR.LT.0.OR.SIGTAL(JR).GT.0.0 )THEN
+               BILAN=BILAN + PROB(IPRF)
+            ENDIF
+   20    CONTINUE
+         IF( IR.LT.0 )THEN
+            IVOL= IVOL+1
+            PROB(IPRB)= PROB(IVOL)-BILAN
+            IF( IPRT.GE.IPRINT )THEN
+              WRITE(IUNOUT,9001) -IR,BILAN
+            ENDIF
+         ELSEIF( IR.GT.0 )THEN
+            IVOL= IVOL+IUNK-1
+            IF( SIGTAL(IR).GT.0.0 )THEN
+*
+*              VOIDS ARE NOT BE RENORMALIZED
+               PROB(IPRB)= PROB(IVOL)-BILAN
+              IF( IPRT.GE.IPRINT )THEN
+                WRITE(IUNOUT,9002) IR,BILAN
+              ENDIF
+            ENDIF
+         ELSE
+            IVOL= IVOL+1
+         ENDIF
+ 100  CONTINUE
+*
+9000  FORMAT('Diagonal correction factors for CP in ',A6)
+9001  FORMAT('Surface ',I10,5X,E15.6)
+9002  FORMAT('Region  ',I10,5X,E15.6)
+      RETURN
+      END
-- 
cgit v1.2.3