summaryrefslogtreecommitdiff
path: root/Dragon/src/PIJWPR.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/PIJWPR.f')
-rw-r--r--Dragon/src/PIJWPR.f222
1 files changed, 222 insertions, 0 deletions
diff --git a/Dragon/src/PIJWPR.f b/Dragon/src/PIJWPR.f
new file mode 100644
index 0000000..b5bf2bc
--- /dev/null
+++ b/Dragon/src/PIJWPR.f
@@ -0,0 +1,222 @@
+*DECK PIJWPR
+ SUBROUTINE PIJWPR(LOPT,NREG,NSOUT,SIGTAL,PROB,SIGVOL,MSYM)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Print-out for probability matrices.
+*
+*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, G. Marleau
+*
+*Parameters: input
+* LOPT print-out form:
+* <= 0 print all PSS/PVS/PVV;
+* > 0 print only PVV.
+* NREG total number of regions.
+* NSOUT number of outer surface.
+* SIGTAL albedo-cross section vector.
+* PROB collision probabilities.
+* SIGVOL region volumes.
+* MSYM matrix format:
+* = 1 symmetric matrix;
+* = 0 non-symmetric full matrix.
+*
+*Comments:
+* Format of compress probability matrix
+* NPLEN=(NREG+NSOUT+2)*(NREG+NSOUT+1)/2
+* IND(I,J)=MAX(I+NSOUT+1,J+NSOUT+1)
+* *(MAX(I+NSOUT+1,J+NSOUT+1)-1)/2
+* +MIN(I+NSOUT+1,J+NSOUT+1)
+* IS=-NSOUT,-1; JS=-NSOUT,IS; I=IND(IS,JS)
+* PROB(I)=VOLSUR(IS)*PSS(IS,JS)
+* IV=1,NREG; JS=-NSOUT,-1; I=IND(IV,JS)
+* SIGT(IV).GT.0.0
+* PROB(I)=SIGT(IV)*VOLSUR(IV)*PVS(IV,JS)
+* SIGT(IV).EQ.0.0
+* PROB(I)=VOLSUR(IV)*PVS(IV,JS)
+* IV=1,NREG; JV=1,IV; I=IND(IV,JV)
+* SIGT(IV).GT.0.0 AND SIGT(JV).GT.0.0
+* PROB(I)=SIGT(IV)*SIGT(JV)*VOLSUR(IV)*PVV(IV,JV)
+* SIGT(IV).GT.0.0 AND SIGT(JV).EQ.0.0
+* PROB(I)=SIGT(IV)*VOLSUR(IV)*PVV(IV,JV)
+* SIGT(IV).EQ.0.0 AND SIGT(JV).GT.0.0
+* PROB(I)=SIGT(JV)*VOLSUR(IV)*PVV(IV,JV)
+* SIGT(IV).EQ.0.0 AND SIGT(JV).EQ.0.0
+* PROB(I)=VOLSUR(IV)*PVV(IV,JV)
+*
+*-----------------------------------------------------------------------
+*
+ IMPLICIT NONE
+ INTEGER IUNOUT, LOPT, NREG, NSOUT, MSYM,
+ > IND, I, J, NSUR, NVOL,
+ > NSURC, NSURM, NVOLC, NVOLM, IP, IR,
+ > JR, III
+ PARAMETER (IUNOUT=6)
+ REAL SIGTAL(-NSOUT:NREG), BILANP(10), XSJR, WPR,
+ > VPR(10), SIGVOL(NREG), COF
+ DOUBLE PRECISION PROB(*)
+*
+ IND(I,J) = MAX(I+NSOUT+1,J+NSOUT+1)*(MAX(I+NSOUT+1,J+NSOUT+1)-1)/2
+ > + MIN(I+NSOUT+1,J+NSOUT+1)
+*
+ WPR(I,J)= REAL(PROB( IND(I,J) ) / PROB( IND(I,0) ))
+*
+*NOTE:
+* IF( SIGT(I).NE.0.0 )THEN
+* PROB(IND(I,0))= SIGT(I) * VOLSUR(I)
+* ELSE
+* PROB(IND(I,0))= VOLSUR(I)
+* ENDIF
+*
+ NSUR= -NSOUT
+ NVOL= NREG
+*
+ WRITE(IUNOUT,'(24H REGIONAL CROSS SECTIONS)')
+ WRITE(IUNOUT,'(5(1X,6HREGION,5X,16HCROSS SECTION ))')
+ WRITE(IUNOUT,'(5(1X,I6,3X,E15.7))') (JR,SIGTAL(JR),JR=1,NVOL)
+ IF(MSYM .EQ. 0) THEN
+ WRITE(IUNOUT,'(5(1X,6HREGION,5X,16HVOLUMES ))')
+ WRITE(IUNOUT,'(5(1X,I6,3X,E15.7))')
+ > (JR,SIGVOL(JR),JR=1,NVOL)
+ ELSE
+ WRITE(IUNOUT,'(5(1X,6HREGION,5X,16HSURFACE/VOLUMES ))')
+ WRITE(IUNOUT,'(5(1X,I6,3X,E15.7))')
+ > (JR,PROB(IND(JR,0)),JR=-NSOUT,NVOL)
+ ENDIF
+ IF( LOPT.LE.0 )THEN
+ NSURC = -1
+ DO 40 IP = 1, (9 - NSUR) / 10
+ NSURM= MAX( NSUR, NSURC-9 )
+ WRITE(IUNOUT,'(30H0 SURFACE CONSERVATION LAWS: ,
+ > 31H( P.S<-S + P.V<-S = 1 + ERR.S ) ,
+ > 31H FOR XS.TOTAL=0, REDUCED P.V<-S ,
+ > 11H IS PRINTED )')
+ WRITE(IUNOUT,'(1X,8H(P.S<-S),1X,10( A5, I6,:)/)')
+ > (' SUR ',-IR,IR= NSURC, NSURM, -1)
+ DO 10 IR =NSURC, NSURM, -1
+ BILANP(IR-NSURM+1)= 0.0
+ 10 CONTINUE
+ DO 25 JR = -1, NSUR, -1
+ WRITE(IUNOUT,'(5H SUR ,I4,1X,10F11.8)')
+ > -JR, (WPR(IR,JR),IR=NSURC,NSURM,-1)
+ DO 20 IR = NSURC, NSURM, -1
+ BILANP(IR-NSURM+1)= BILANP(IR-NSURM+1)
+ > + WPR(IR,JR)
+ 20 CONTINUE
+ 25 CONTINUE
+ WRITE(IUNOUT,'(1X,8H(P.V<-S) )')
+ DO 35 JR = 1, NVOL, 1
+ IF( SIGTAL(JR).EQ.0.0 ) THEN
+ WRITE(IUNOUT,'(5H VOL ,I4,1X,3H 0*,10(F8.5,:,3H 0*))')
+ > JR,(WPR(IR,JR),IR=NSURC,NSURM,-1)
+ XSJR= 0.0
+ ELSE
+ WRITE(IUNOUT,'(5H VOL ,I4,1X,10F11.8)')
+ > JR,(WPR(IR,JR),IR=NSURC,NSURM,-1)
+ XSJR= 1.0
+ ENDIF
+ DO 30 IR = NSURC, NSURM, -1
+ BILANP(IR-NSURM+1)= BILANP(IR-NSURM+1)
+ > + XSJR * WPR(IR,JR)
+ 30 CONTINUE
+ 35 CONTINUE
+ WRITE(IUNOUT,'(1H )')
+ WRITE(IUNOUT,'(5H SUM ,5X,10F11.8)')
+ > (BILANP(IR-NSURM+1),IR=NSURC,NSURM,-1)
+ NSURC = NSURC - 10
+ 40 CONTINUE
+ ENDIF
+ NVOLC = 1
+ DO 90 IP = 1, (9 + NVOL) / 10
+ NVOLM= MIN( NVOL, NVOLC+9 )
+ IF( LOPT.LE.0 )THEN
+ WRITE(IUNOUT,'(30H0 VOLUME CONSERVATION LAWS: ,
+ > 31H( P.S<-V + P.V<-V = 1 + ERR.V ) ,
+ > 31H FOR XS.TOTAL=0, REDUCED P.V<-V ,
+ > 11H IS PRINTED )')
+ ELSE
+ WRITE(IUNOUT,'(30H0 VOLUME CONSERVATION LAWS: ,
+ > 32H( SUM OF P.V<-V = 1 + ESCAPE.V ) ,
+ > 31H FOR XS.TOTAL=0, REDUCED P.V<-V ,
+ > 11H IS PRINTED )')
+ ENDIF
+ DO 50 IR = NVOLC, NVOLM, 1
+ BILANP(IR-NVOLC+1)= 0.0
+ 50 CONTINUE
+ IF( LOPT.LE.0 )THEN
+ WRITE(IUNOUT,'(1X,8H(P.S<-V),1X,10( A5 , I6,:)/)')
+ > (' VOL ',IR,IR=NVOLC,NVOLM, 1)
+ DO 65 JR = -1, NSUR, -1
+ WRITE(IUNOUT,'(5H SUR ,I4,1X,10F11.8)')
+ > -JR, (WPR(IR,JR),IR=NVOLC,NVOLM, 1)
+ DO 60 IR = NVOLC, NVOLM, 1
+ BILANP(IR-NVOLC+1)= BILANP(IR-NVOLC+1)
+ > + WPR(IR,JR)
+ 60 CONTINUE
+ 65 CONTINUE
+ WRITE(IUNOUT,'(1X,8H(P.V<-V) )')
+ ELSE
+ WRITE(IUNOUT,'(1X,8H(P.V<-V),1X,10( A5 , I6,:)/)')
+ > (' VOL ',IR,IR=NVOLC,NVOLM, 1)
+ ENDIF
+*
+ IF(LOPT.GT.0.AND.MSYM.EQ.0)THEN
+*
+* PRINTING OF PIJK" FULL MATRIX
+*
+ COF=1.5
+ DO 70 JR = 1, NVOL, 1
+ IF( SIGTAL(JR).EQ.0.0 )THEN
+ DO 75 IR=NVOLC, NVOLM, 1
+ III=JR+NREG*(IR-1)
+ VPR(IR-NVOLC+1)=COF*REAL(PROB(III))/SIGVOL(IR)
+ 75 CONTINUE
+ WRITE(IUNOUT,'(5H VOL ,I4,1X,3H 0*,10(F8.5,:,3H 0*))')
+ > JR,(VPR(IR-NVOLC+1),IR=NVOLC,NVOLM,1)
+ ELSE
+ DO 76 IR=NVOLC, NVOLM, 1
+ III=JR+NREG*(IR-1)
+ VPR(IR-NVOLC+1)=COF*REAL(PROB(III))/SIGVOL(IR)
+ BILANP(IR-NVOLC+1)=BILANP(IR-NVOLC+1)+VPR(IR-NVOLC+1)
+ 76 CONTINUE
+ WRITE(IUNOUT,'(5H VOL ,I4,1X,10F11.8)')
+ > JR,(VPR(IR-NVOLC+1),IR=NVOLC,NVOLM,1)
+ ENDIF
+ 70 CONTINUE
+ WRITE(IUNOUT,'(1H )')
+ WRITE(IUNOUT,'(5H SUM ,5X,10F11.8)')
+ > (BILANP(IR-NVOLC+1),IR=NVOLC,NVOLM, 1)
+*
+ ELSE
+*
+ DO 85 JR = 1, NVOL, 1
+ IF( SIGTAL(JR).EQ.0.0 )THEN
+ WRITE(IUNOUT,'(5H VOL ,I4,1X,3H 0*,10(F8.5,:,3H 0*))')
+ > JR,(WPR(IR,JR),IR=NVOLC,NVOLM,1)
+ XSJR= 0.0
+ ELSE
+ WRITE(IUNOUT,'(5H VOL ,I4,1X,10F11.8)')
+ > JR,(WPR(IR,JR),IR=NVOLC,NVOLM,1)
+ XSJR= 1.0
+ ENDIF
+ DO 80 IR = NVOLC, NVOLM, 1
+ BILANP(IR-NVOLC+1)= BILANP(IR-NVOLC+1)
+ > + XSJR*WPR(IR,JR)
+ 80 CONTINUE
+ 85 CONTINUE
+ WRITE(IUNOUT,'(1H )')
+ WRITE(IUNOUT,'(5H SUM ,5X,10F11.8)')
+ > (BILANP(IR-NVOLC+1),IR=NVOLC,NVOLM, 1)
+ ENDIF
+ NVOLC = NVOLC + 10
+ 90 CONTINUE
+*
+ RETURN
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 13:15:58 +0000