1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
*DECK PIJCMP
SUBROUTINE PIJCMP(NREG,NSOUT,NCOR,DPR,VOLSUR,LPIJK,PROB)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Compression of PIJ matrices in symmetric format.
*
*Copyright:
* Copyright (C) 1994 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
* NREG number of zones for geometry.
* NSOUT number of surfaces for geometry.
* NCOR maximum number of corners.
* DPR collision probabilities.
* VOLSUR volumes.
* LPIJK pijk flag.
*
*Parameters: output
* PROB compress probability 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
*----
* VARIABLES
*----
INTEGER NREG,NSOUT,NCOR,IPR,IL,JL,IVOL,IUN
DOUBLE PRECISION DPR(-NSOUT:NREG,-NSOUT:NREG),PROB(*),ZCOR,ZCOR1
REAL VOLSUR(-NSOUT:NREG),COEF
LOGICAL LPIJK
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: WORK
*----
* SCRATCH STORAGE ALLOCATION
*----
ALLOCATE(WORK((NREG+NSOUT+2)*(NREG+NSOUT+1)/2))
*----
* SYMMETRIZE AND STORE IN PROB
*----
IPR= 0
DO 150 IL = -NSOUT, NREG
DO 160 JL = -NSOUT, IL
IPR= IPR+1
WORK(IPR)= DPR(IL,JL) + DPR(JL,IL)
160 CONTINUE
150 CONTINUE
IF( NCOR.EQ.1 )THEN
IPR= 0
DO 250 IL = -NSOUT, NREG
DO 260 JL = -NSOUT, IL
IPR= IPR+1
PROB(IPR)= WORK(IPR)
260 CONTINUE
250 CONTINUE
ELSE
IPR= 0
ZCOR1= 1.0D0/DBLE(NCOR)
ZCOR= 1.0D0/DBLE(NCOR*NCOR)
DO 251 IL = -NSOUT, NREG
IF( IL.GT.0 ) ZCOR= ZCOR1
DO 261 JL = -NSOUT, IL
IPR= IPR+1
IF( JL.GT.0 ) ZCOR= 1.0D0
PROB(IPR)= ZCOR * WORK(IPR)
261 CONTINUE
251 CONTINUE
ENDIF
*----
* CHARGE VOLUMES IN THE PROB MATRIX
*----
COEF=1.0
IVOL= NSOUT*(NSOUT+1)/2
DO 300 IUN= -NSOUT, NREG
IF( IUN.LE.0 )THEN
IVOL= IVOL+1
IF(LPIJK) COEF= 3./4.
ELSE
IVOL= IVOL+NSOUT+IUN
IF(LPIJK) COEF= 2./3.
ENDIF
IF( PROB(IVOL).NE.0.0 )THEN
CALL XABORT( 'PIJCMP: UNEXPECTED VALUE IN PROB MATRIX' )
ENDIF
PROB(IVOL) = VOLSUR(IUN)*COEF
300 CONTINUE
*----
* SCRATCH STORAGE DEALLOCATION
*----
DEALLOCATE(WORK)
RETURN
END
|
