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
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
*DECK XELCTR
SUBROUTINE XELCTR(IFOLD,IFTRK,MXSUBO,MXSEGO,CUTOFX,ALBEDO)
*
*-----------------------------------------------------------------------
*
*Purpose:
* EXCELL prismatic tracking.
*
*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
* IFOLD unnormalized tracking file number (at input).
* IFTRK normalized tracking file number (at output).
* MXSUBO undefined.
* MXSEGO undefined.
* CUTOFX cutoff factor.
* ALBEDO geometric albedos on external faces.
*
*-----------------------------------------------------------------------
*
IMPLICIT NONE
INTEGER IFOLD,IFTRK,MXSUBO,MXSEGO
REAL CUTOFX,ALBEDO(6)
INTEGER NCOMNT,NSCRP,NDIM,ISPEC,NREG,NSOUT,NALBG,NCOR,NANGL,NRS,
1 ICODE(6),II,JJ,NBTRK,MXSUB,MXSEG,NSUB,LINE,ITRAK,NOLDS,NNEWS,
2 NCSEG
REAL VOLMIN,ASCRP
DOUBLE PRECISION WEIGHT,RCUT,DASCRP
CHARACTER CTRK*4,COMENT*80
*----
* ALLOCATABLE ARRAYS
*----
INTEGER, ALLOCATABLE, DIMENSION(:) :: MATALB,NRSEG,KANGL
REAL, ALLOCATABLE, DIMENSION(:) :: VOLSUR
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: ANGLE,DENSTY
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SEGLEN
*---
* Read Old Tracking File
*---
READ (IFOLD) CTRK,NCOMNT,NSCRP,NSCRP
DO II=1,NCOMNT
READ(IFOLD) COMENT
ENDDO
READ (IFOLD) NDIM,ISPEC,NREG,NSOUT,NALBG,NCOR,NANGL,NSCRP,NSCRP
IF(NALBG.LE.0.OR.NALBG.GT.6)THEN
CALL XABORT('XELCTR: NALBG.GT.6.OR.NALBG.LE.0'//
1 ' ON TRACKING FILE')
ENDIF
NRS=NREG+NSOUT+1
ALLOCATE(MATALB(NRS),NRSEG(MXSEGO),KANGL(MXSUBO))
ALLOCATE(VOLSUR(NRS),ANGLE(NDIM*NANGL),DENSTY(NANGL),
1 SEGLEN(MXSEGO))
READ (IFOLD) (VOLSUR(II),II=1,NRS)
READ (IFOLD) (MATALB(II),II=1,NRS)
READ (IFOLD) (ICODE(II),II=1,NALBG)
READ (IFOLD) (ALBEDO(II),II=1,NALBG)
READ (IFOLD) ((ANGLE((JJ-1)*NDIM+II),II=1,NDIM),JJ=1,NANGL)
READ (IFOLD) (DENSTY(II),II=1,NANGL)
VOLMIN=VOLSUR(NSOUT+2)
DO II= NSOUT+2,NSOUT+NREG
VOLMIN=MIN(VOLMIN,VOLSUR(II+1))
ENDDO
RCUT=VOLMIN*CUTOFX
NBTRK= 0
MXSUB= 0
MXSEG= 0
20 CONTINUE
READ(IFOLD,END=40) NSUB,LINE,WEIGHT,(KANGL(II),II=1,NSUB),
1 (NRSEG(II),II=1,LINE),(SEGLEN(II),II=1,LINE)
MXSUB=MAX(MXSUB,NSUB)
MXSEG=MAX(MXSEG,LINE)
NBTRK=NBTRK+1
GOTO 20
40 CONTINUE
*---
* Construct New Tracking File
*---
REWIND IFOLD
READ (IFOLD) CTRK,NSCRP,NSCRP,NSCRP
WRITE(IFTRK) CTRK,NCOMNT,NBTRK,0
DO II=1,NCOMNT
READ (IFOLD) COMENT
WRITE(IFTRK) COMENT
ENDDO
READ (IFOLD) (NSCRP,II=1,8)
WRITE(IFTRK) NDIM,ISPEC,NREG,NSOUT,NALBG,NCOR,NANGL,MXSUB,MXSEG
READ (IFOLD) (ASCRP,II=-NSOUT,NREG)
WRITE(IFTRK) (VOLSUR(II),II=1,NRS)
READ (IFOLD) (NSCRP,II=-NSOUT,NREG)
WRITE(IFTRK) (MATALB(II),II=1,NRS)
READ (IFOLD) (NSCRP,II=1,NALBG)
WRITE(IFTRK) (ICODE(II),II=1,NALBG)
READ (IFOLD) (ASCRP,II=1,NALBG)
WRITE(IFTRK) (ALBEDO(II),II=1,NALBG)
READ (IFOLD) ((DASCRP,II=1,NDIM),JJ=1,NANGL)
WRITE(IFTRK) ((ANGLE((JJ-1)*NDIM+II),II=1,NDIM),JJ=1,NANGL)
READ (IFOLD) (DASCRP,II=1,NANGL)
WRITE(IFTRK) (DENSTY(II),II=1,NANGL)
DO ITRAK=1, NBTRK
READ(IFOLD) NSUB,LINE,WEIGHT,(KANGL(II),II=1,NSUB),
1 (NRSEG(II),II=1,LINE),(SEGLEN(II),II=1,LINE)
IF (RCUT.GT.0.0)THEN
II=0
23 CONTINUE
IF (II.EQ.LINE) GO TO 25
II=II+1
IF (SEGLEN(II).LT.RCUT) THEN
IF (II.NE.LINE) THEN
DO JJ= II+1, LINE
NRSEG(JJ-1)=NRSEG(JJ)
SEGLEN(JJ-1)=SEGLEN(JJ)
ENDDO
ELSE
LINE=LINE-1
GOTO 25
ENDIF
LINE=LINE-1
II=II-1
ENDIF
GOTO 23
25 CONTINUE
ENDIF
NOLDS=NRSEG(1)
NCSEG=1
DO II=2,LINE
NNEWS=NRSEG(II)
IF ((NNEWS.LT.0).OR.(NNEWS.NE.NOLDS)) THEN
NOLDS=NNEWS
NCSEG=NCSEG+1
NRSEG(NCSEG)=NRSEG(II)
SEGLEN(NCSEG)=SEGLEN(II)
ELSEIF (NNEWS.EQ.NOLDS) THEN
SEGLEN(NCSEG)=SEGLEN(NCSEG)+SEGLEN(II)
ENDIF
ENDDO
WRITE(IFTRK) NSUB,NCSEG,WEIGHT,(KANGL(II),II=1,NSUB),
1 (NRSEG(II),II=1,NCSEG),(SEGLEN(II),II=1,NCSEG)
ENDDO
DEALLOCATE(SEGLEN,DENSTY,ANGLE,VOLSUR)
DEALLOCATE(KANGL,NRSEG,MATALB)
*
RETURN
END
|
