summaryrefslogtreecommitdiff
path: root/Dragon/src
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src')
-rw-r--r--Dragon/src/EXCELP.f28
-rw-r--r--Dragon/src/MCGSIG.f4
-rw-r--r--Dragon/src/MUSACG.f9010
-rw-r--r--Dragon/src/PIJWIJ.f18
-rw-r--r--Dragon/src/SALACG.f9030
-rw-r--r--Dragon/src/SALTCG.f16
6 files changed, 65 insertions, 41 deletions
diff --git a/Dragon/src/EXCELP.f b/Dragon/src/EXCELP.f
index 77a9fab..9781c59 100644
--- a/Dragon/src/EXCELP.f
+++ b/Dragon/src/EXCELP.f
@@ -85,18 +85,18 @@
*----
* LOCAL VARIABLES
*----
- INTEGER IOUT, ICPALL, ICPEND, MXGAUS, NSTATE
+ INTEGER IOUT, ICPALL, ICPEND, MXGAUS, NSTATE, MAXCDA
PARAMETER ( IOUT=6, ICPALL=4, ICPEND=3, MXGAUS=64,
- > NSTATE=40 )
+ > NSTATE=40, MAXCDA=30 )
CHARACTER NAMSBR*6
PARAMETER ( NAMSBR='EXCELP')
INTEGER MKI1, MKI2, MKI3, MKI4, MKI5
PARAMETER (MKI1=600,MKI2=600,MKI3=600,MKI4=600,MKI5=600)
- INTEGER ISTATE(NSTATE),ICODE(6)
+ INTEGER ISTATE(NSTATE),ICODE(MAXCDA)
INTEGER NPROB,ISBG,KSBG,ITYPBC
- REAL ALBEDO(6),EXTKOP(NSTATE),CUTOF,RCUTOF,ASCRP,
- > YGSS,XGSS(MXGAUS),WGSS(MXGAUS),WGSSX(MXGAUS),
- > ALBG(6)
+ REAL ALBEDO(MAXCDA),EXTKOP(NSTATE),CUTOF,RCUTOF,
+ > ASCRP,YGSS,XGSS(MXGAUS),WGSS(MXGAUS),
+ > WGSSX(MXGAUS),ALBG(MAXCDA)
LOGICAL SWVOID, LPIJK
CHARACTER CTRKT*4, COMENT*80
DOUBLE PRECISION DANG0,DASCRP
@@ -104,7 +104,8 @@
INTEGER JJ,MSYM,IL,NALLOC,ITRAK,IANG,IC,IPRT,ISPEC,
> IUN,KSPEC,LOPT,MXSEG,NALBG,NANGL,NCOMNT,NCOR,
> NCORT,NDIM,NGSS,NREG2,NSCRP,NTRK,NUNKNO,JGSS,
- > JUN,IFMT,MXSUB,ISA,IBATCH,IL1 ,III,IND,I,J
+ > JUN,IFMT,MXSUB,ISA,IBATCH,IL1,III,IND,I,J,
+ > ILONG,ITYLCM
*----
* Variables for NXT: inline tracking
*----
@@ -153,7 +154,7 @@
1 + MIN(I+NSOUT+1,J+NSOUT+1)
*----
* RECOVER EXCELL SPECIFIC TRACKING INFORMATION.
-* ALBEDO: SURFACE ALBEDOS (REAL(6))
+* ALBEDO: SURFACE ALBEDOS (REAL(MAXCDA))
* KSPEC : KIND OF PIJ INTEGRATION (0:ISOTROPE,1:SPECULAR)
* CUTOF : MFP CUTOFF FOR SPECULAR INTEGRATION
*----
@@ -162,6 +163,9 @@
KSPEC=ISTATE(10)
CALL LCMGET(IPTRK,'EXCELTRACKOP',EXTKOP)
CUTOF=EXTKOP(1)
+ CALL LCMLEN(IPTRK,'ICODE',ILONG,ITYLCM)
+ IF(ILONG.GT.MAXCDA) CALL XABORT('EXCELP: MAXCDA OVERFLOW(1).')
+ ICODE(:MAXCDA)=0
CALL LCMGET(IPTRK,'ICODE',ICODE)
CALL LCMGET(IPTRK,'ALBEDO',ALBG)
*
@@ -269,16 +273,16 @@
SWVOID= .FALSE.
DO ISBG=1,NSBG
IF(NPSYS(ISBG).NE.0) THEN
- DO ISA=1,6
- ALBEDO(ISA)=ALBG(ISA)
- ENDDO
+ ALBEDO(:MAXCDA)=ALBG(:MAXCDA)
IF(NALBP .GT. 0) THEN
- DO ISA=1,6
+ DO ISA=1,MAXCDA
IF(ICODE(ISA).GT.0) ALBEDO(ISA)=ALBP(ICODE(ISA),ISBG)
ENDDO
ENDIF
DO IUN= -NSOUT, -1
SIGT00(IUN,ISBG)= 0.0
+ IF(-MATALB(IUN).GT.MAXCDA) CALL XABORT('EXCELP: MAXCDA OV'
+ > //'ERFLOW(2).')
SIGTAL(IUN,ISBG)= ALBEDO(-MATALB(IUN))
SWNZBC= SWNZBC.OR.(SIGTAL(IUN,ISBG).NE.0.0)
ENDDO
diff --git a/Dragon/src/MCGSIG.f b/Dragon/src/MCGSIG.f
index 9509841..3589cd6 100644
--- a/Dragon/src/MCGSIG.f
+++ b/Dragon/src/MCGSIG.f
@@ -41,12 +41,14 @@
* LOCAL VARIABLES
*---
TYPE(C_PTR) JPSYS
- INTEGER I,II,ISA,ICODE(6)
+ INTEGER I,II,ISA,ICODE(6),ILONG,ITYLCM
REAL ALBG(6),ALBEDO(6)
REAL, ALLOCATABLE, DIMENSION(:) :: ALBP
*---
* RECOVER ALBEDO INFORMATION FROM TRACKING
*---
+ CALL LCMLEN(IPTRK,'ICODE',ILONG,ITYLCM)
+ IF(ILONG.GT.6) CALL XABORT('MCGSIG: ALBEDO OVERFLOW.')
CALL LCMGET(IPTRK,'ICODE',ICODE)
CALL LCMGET(IPTRK,'ALBEDO',ALBG)
*
diff --git a/Dragon/src/MUSACG.f90 b/Dragon/src/MUSACG.f90
index 9ceaeb8..3d560e4 100644
--- a/Dragon/src/MUSACG.f90
+++ b/Dragon/src/MUSACG.f90
@@ -54,12 +54,14 @@ SUBROUTINE MUSACG(ITRACK,IFTRK,IPRINT,IMACRO,NBSLIN,RCUTOF,GG,LGINF,NBNODE_MACRO
INTEGER, PARAMETER :: NSTATE=40
INTEGER, PARAMETER :: FOUT=6
INTEGER, PARAMETER :: NDIM=2 ! NUMBER OF DIMENSIONS
+ INTEGER, PARAMETER :: MAXCDA=30 ! MAXIMUM NUMBER OF PERIMETERS
INTEGER ELEM, OK, TYPE
REAL(PDB) :: X1,X2,Y1,Y2,DET1,DET2
REAL(PDB) :: DGMESHX(2),DGMESHY(2)
LOGICAL :: LTEST
INTEGER, DIMENSION(NSTATE) :: I_STATE,IEDIMG
CHARACTER(LEN=72) :: TEXT72
+ CHARACTER(LEN=131) :: HSMG
!----
! Allocatable arrays
!----
@@ -384,7 +386,11 @@ SUBROUTINE MUSACG(ITRACK,IFTRK,IPRINT,IMACRO,NBSLIN,RCUTOF,GG,LGINF,NBNODE_MACRO
WRITE(FOUT,'(3HEND)')
WRITE(FOUT,'(5H--cut,70(1H-),I5)') IMACRO
ENDIF
- IF(GG_MAC%NBBCDA.GT.6) CALL XABORT('MUSACG: The unfolded geometry has more than 6 perimeters')
+ IF(GG_MAC%NBBCDA.GT.MAXCDA) THEN
+ WRITE(HSMG,'(33HMUSACG: The unfolded geometry has,I3,14H perimeters (>,I3,2H).)') &
+ & GG_MAC%NBBCDA,MAXCDA
+ CALL XABORT(HSMG)
+ ENDIF
!****
!* compute node perimeters for the macro
ALLOCATE (GG_MAC%PPERIM_NODE(GG_MAC%NB_NODE+1),STAT=OK)
@@ -649,7 +655,7 @@ SUBROUTINE MUSACG(ITRACK,IFTRK,IPRINT,IMACRO,NBSLIN,RCUTOF,GG,LGINF,NBNODE_MACRO
MATALB(-I)=-1
GALBED(1)=REAL(GG_MAC%ALBEDO)
ELSE
- IF(INDEX.GT.6) CALL XABORT('MUSACG: SDIRE overflow.')
+ IF(INDEX.GT.MAXCDA) CALL XABORT('MUSACG: INDEX overflow.')
IF(INDEX > GG_MAC%NALBG) THEN
CALL XABORT('MUSACG: Albedo array overflow(2).')
ENDIF
diff --git a/Dragon/src/PIJWIJ.f b/Dragon/src/PIJWIJ.f
index c4d9e11..bea36a2 100644
--- a/Dragon/src/PIJWIJ.f
+++ b/Dragon/src/PIJWIJ.f
@@ -88,13 +88,14 @@
*----
* LOCAL VARIABLES
*----
- INTEGER IOUT, ICPALL, ICPEND, MXGAUS, NSTATE
+ INTEGER IOUT, ICPALL, ICPEND, MXGAUS, NSTATE, MAXCDA
PARAMETER ( IOUT=6, ICPALL=4, ICPEND=3, MXGAUS=64,
- > NSTATE=40 )
+ > NSTATE=40, MAXCDA=30 )
CHARACTER NAMSBR*6
PARAMETER ( NAMSBR='PIJWIJ')
- INTEGER ILONG,ITYPE,NPROB,ISBG,ISTATE(NSTATE),ICODE(6)
- REAL FACT,ALBEDO(6),ALBG(6)
+ INTEGER ILONG,ITYPE,NPROB,ISBG,ISTATE(NSTATE),
+ > ICODE(MAXCDA)
+ REAL FACT,ALBEDO(MAXCDA),ALBG(MAXCDA)
LOGICAL LSKIP,SWNZBC,SWVOID
*
INTEGER MSYM,IU,IL,ISOUT,IIN,I,J,IBM,IOP,INDPIJ,IJKS,
@@ -125,6 +126,9 @@
ISTATE(:NSTATE)=0
CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE)
KSPEC=ISTATE(10)
+ CALL LCMLEN(IPTRK,'ICODE',ILONG,ITYPE)
+ IF(ILONG.GT.MAXCDA) CALL XABORT('PIJWIJ: MAXCDA OVERFLOW(1).')
+ ICODE(:MAXCDA)=0
CALL LCMGET(IPTRK,'ICODE',ICODE)
CALL LCMGET(IPTRK,'ALBEDO',ALBG)
*----
@@ -135,11 +139,9 @@
SWVOID= .FALSE.
DO ISBG=1,NSBG
IF(NPSYS(ISBG).NE.0) THEN
- DO ISA=1,6
- ALBEDO(ISA)=ALBG(ISA)
- ENDDO
+ ALBEDO(:MAXCDA)=ALBG(:MAXCDA)
IF(NALBP .GT. 0) THEN
- DO ISA=1,6
+ DO ISA=1,MAXCDA
IF(ICODE(ISA).GT.0) ALBEDO(ISA)=ALBP(ICODE(ISA),ISBG)
ENDDO
ENDIF
diff --git a/Dragon/src/SALACG.f90 b/Dragon/src/SALACG.f90
index 0dbc708..679446c 100644
--- a/Dragon/src/SALACG.f90
+++ b/Dragon/src/SALACG.f90
@@ -45,13 +45,14 @@ SUBROUTINE SALACG(FGEO ,ITRACK, RCUTOF, IPRINT, GG)
! Local variables
!----
INTEGER, PARAMETER :: NSTATE=40
- INTEGER, PARAMETER :: NDIM=2 ! NUMBER OF DIMENSIONS
- INTEGER, PARAMETER :: NALBG=6 ! NUMBER OF ALBEDOS
+ INTEGER, PARAMETER :: NDIM=2 ! NUMBER OF DIMENSIONS
+ INTEGER, PARAMETER :: MAXCDA=30 ! MAXIMUM NUMBER OF ALBEDOS
LOGICAL LGINF
INTEGER, DIMENSION(NSTATE) :: I_STATE,IEDIMG
- INTEGER OK,I,J,NREG,ELEM,NFREG,LEAK,NSOUT,ICODE(NALBG),INDEX,MMAX
- REAL GALBED(NALBG)
+ INTEGER NALBG,OK,I,J,NREG,ELEM,NFREG,LEAK,NSOUT,ICODE(MAXCDA),INDEX,MMAX
+ REAL GALBED(MAXCDA)
CHARACTER(LEN=72) TEXT72
+ CHARACTER(LEN=131) HSMG
REAL(PDB) :: DGMESHX(2),DGMESHY(2)
!----
! Allocatable arrays
@@ -234,10 +235,16 @@ SUBROUTINE SALACG(FGEO ,ITRACK, RCUTOF, IPRINT, GG)
VOLSUR(1:NREG)=VOLUME(:NREG)
DEALLOCATE(VOLUME)
! boundary conditions structures
- ICODE(:NALBG)=(/ (-I,I=1,NALBG) /)
- GALBED(:NALBG)=REAL(GG%ALBEDO)
+ ICODE(:MAXCDA)=(/ (-I,I=1,MAXCDA) /)
+ GALBED(:MAXCDA)=REAL(GG%ALBEDO)
+ IF(GG%NALBG.GT.MAXCDA) THEN
+ WRITE(HSMG,'(24HSALACG: The geometry has,I3,17H albedo values (>,I3,2H).)') &
+ & GG%NALBG,MAXCDA
+ CALL XABORT(HSMG)
+ ENDIF
IF(ISPEC == 0) THEN
- IF(GG%NALBG > 6) CALL XABORT('SALACG: Albedo array overflow(1).')
+ NALBG=GG%NALBG
+ IF(TYPGEO.EQ.0) NALBG=6
DO I=1,NSOUT
KEYMRG(-I)=-I
VOLSUR(-I)=GG%SURF2(I)
@@ -247,10 +254,8 @@ SUBROUTINE SALACG(FGEO ,ITRACK, RCUTOF, IPRINT, GG)
MATALB(-I)=-1
GALBED(1)=REAL(GG%ALBEDO)
ELSE
- IF(INDEX.GT.6) CALL XABORT('SALACG: SDIRE overflow.')
- IF(INDEX > GG%NALBG) THEN
- CALL XABORT('SALACG: Albedo array overflow(2).')
- ENDIF
+ IF(INDEX.GT.MAXCDA) CALL XABORT('SALACG: INDEX overflow(1).')
+ IF(INDEX.GT.GG%NALBG) CALL XABORT('SALACG: INDEX overflow(2).')
MATALB(-I)=-INDEX
IF(SIZE(GG%BCDATA) > 0) THEN
GALBED(INDEX)=REAL(GG%BCDATA(6,INDEX))
@@ -260,13 +265,14 @@ SUBROUTINE SALACG(FGEO ,ITRACK, RCUTOF, IPRINT, GG)
ENDIF
ENDDO
ELSE
+ NALBG=6
DO I=1,NSOUT
VOLSUR(-I)=0.0
KEYMRG(-I)=-I
MATALB(-I)=-1
ENDDO
GALBED(:NALBG)=1.0
- ENDIF
+ ENDIF
MATALB(0)=0
KEYMRG(0)=0
VOLSUR(0)=0._PDB
diff --git a/Dragon/src/SALTCG.f b/Dragon/src/SALTCG.f
index 123a288..dcf496f 100644
--- a/Dragon/src/SALTCG.f
+++ b/Dragon/src/SALTCG.f
@@ -57,10 +57,10 @@
PARAMETER (IOUT=6,NAMSBR='SALTCG')
INTEGER NSTATE
PARAMETER (NSTATE=40)
- INTEGER NMAX0
+ INTEGER NMAX0,MAXCDA
DOUBLE PRECISION PI,DZERO,DONE,DTWO,DSUM
PARAMETER (PI=3.14159265358979, DZERO=0.0D0,DONE=1.0D0,
- > DTWO=2.0D0,NMAX0=100000)
+ > DTWO=2.0D0,NMAX0=100000,MAXCDA=30)
*----
* Functions
*----
@@ -68,8 +68,8 @@
*----
* Local variables
*----
- INTEGER ISTATE(NSTATE),IEDIMG(NSTATE),ICODE(6)
- REAL RSTATT(NSTATE),ALBEDO(6)
+ INTEGER ISTATE(NSTATE),IEDIMG(NSTATE),ICODE(MAXCDA)
+ REAL RSTATT(NSTATE),ALBEDO(MAXCDA)
INTEGER RENO,LTRK,AZMOAQ,ISYMM,POLQUA,POLOAQ,AZMQUA,
> AZMNBA,OK
DOUBLE PRECISION DENUSR,RCUTOF,DENLIN,SPACLN,WEIGHT
@@ -81,7 +81,7 @@
> MAXSUB,MAXSGL,NBDR,ILONG,ITYLCM,IPER(3)
INTEGER JJ,KK,NCOR,NQUAD,NANGL,NBANGL,LINMAX
DOUBLE PRECISION DQUAD(4),ABSC(3,2),RCIRC,SIDEH,ANGLE
- CHARACTER CTRK*4,COMENT*80
+ CHARACTER CTRK*4,COMENT*80,HSMG*131
INTEGER IFMT,NEREG,NESUR
*----
* Allocatable arrays
@@ -132,7 +132,11 @@
* Get main tracking records
*----
CALL LCMLEN(IPTRK,'ICODE ',ILONG,ITYLCM)
- IF(ILONG.GT.6) CALL XABORT('SALTCG: ALBEDO OVERFLOW.')
+ IF(ILONG.GT.MAXCDA) THEN
+ WRITE(HSMG,'(24HSALTCG: The geometry has,I3,15H albedo values ,
+ 1 2H(>,I3,2H).)') ILONG,MAXCDA
+ CALL XABORT(HSMG)
+ ENDIF
CALL LCMGET(IPTRK,'ICODE ',ICODE )
CALL LCMGET(IPTRK,'ALBEDO ',ALBEDO)
CALL LCMSIX(IPTRK,'NXTRecords ',1)
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 17:29:38 +0000