Merge branch '8-correct-sfr-geometry-issues-in-module-salt' into 'main'

Resolve "Correct SFR geometry issues in module SALT:"

See merge request dragon/5.1!16

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)