Initial commit from Polytechnique Montreal

1 files changed, 154 insertions, 0 deletions

diff --git a/Dragon/src/XELCTR.f b/Dragon/src/XELCTR.f
new file mode 100644
index 0000000..12cd250
--- /dev/null
+++ b/Dragon/src/XELCTR.f
@@ -0,0 +1,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