Merge branch '22-issue-with-the-partial-homogenization-of-a-colorset' into 'main'

#22: Issue with the partial homogenization of a colorset

See merge request dragon/5.1!43

3 files changed, 27 insertions, 40 deletions

diff --git a/Dragon/src/APXCA2.f b/Dragon/src/APXCA2.f
index 97aa69e..6663435 100644
--- a/Dragon/src/APXCA2.f
+++ b/Dragon/src/APXCA2.f
@@ -67,7 +67,7 @@
 *----
 *  ALLOCATABLE ARRAYS
 *----
-      INTEGER, ALLOCATABLE, DIMENSION(:) :: MIX,ITYPE
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: MIX,ITYPE,IDEPL
       INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONAM
       REAL, ALLOCATABLE, DIMENSION(:) :: OVERV,WORKD,WORK1,WORK2,DEN,
      1 DENISO,ENRGS,VOLMIX,WORK1D
@@ -80,7 +80,7 @@
 *----
 *  SCRATCH STORAGE ALLOCATION
 *----
-      ALLOCATE(ISONAM(3,NBISO),MIX(NBISO),ITYPE(NBISO))
+      ALLOCATE(ISONAM(3,NBISO),MIX(NBISO),ITYPE(NBISO),IDEPL(NBISO))
       ALLOCATE(OVERV(NG),DNUSIG(NG,NPRC+1),DCHI(NG,NPRC),WORKD(NPRC),
      1 WORK1(NG*NMIL+1),WORK2(NG),DEN(NBISO),DENISO(NISO),
      2 CONCES(NISO,NMIL),IPERM(NISO,NMIL),VOLMIX(NMIL))
@@ -170,8 +170,10 @@
           CALL LCMGET(IPTEMP,'ISOTOPESMIX',MIX)
           CALL LCMGET(IPTEMP,'ISOTOPESDENS',DEN)
           CALL LCMGET(IPEDIT,'ISOTOPESTYPE',ITYPE)
+          CALL LCMGET(IPEDIT,'ISOTOPESTODO',IDEPL)
           CALL LIBIPS(IPTEMP,NBISO,IPISO)
           DO IBISO=1,NBISO
+            IF(IDEPL(IBISO).EQ.1) CYCLE
             IMIL=MIX(IBISO)
             IF(IMIL.EQ.0) CYCLE
             WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3)
@@ -187,6 +189,7 @@
         ENDIF
         DO ISO=1,NISO
           DO IMIL=1,NMIL
+            IF(CONCES(ISO,IMIL).EQ.0.0) GO TO 10
             IF(C_ASSOCIATED(IPERM(ISO,IMIL))) GO TO 10
           ENDDO
           WRITE(HSMG,'(17HAPXCA2: ISOTOPE '',A8,7H'' (ISO=,I8,3H) I,
@@ -204,12 +207,15 @@
           DO 40 ISO=1,NISO
           IISOTS=0
           DO 20 IBISO=1,NBISO
-          IISOTS=ISO
+          IF(IDEPL(IBISO).EQ.1) GO TO 20
           IF(MIX(IBISO).EQ.0) GO TO 20
+          IISOTS=ISO
           WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3)
           IF(TEXT12(:8).EQ.NOMISO(ISO)) GO TO 30
    20     CONTINUE
-          CALL XABORT('APXCA2: CANNOT FIND ISOTOPE '//NOMISO(ISO)//'.')
+          WRITE(6,'(48H APXCA2: **WARNING** UNABLE TO FIND THE RADIOACT,
+     1    31HIVE DECAY CONSTANT FOR ISOTOPE ,A,1H.)') TRIM(NOMISO(ISO))
+          GO TO 40
    30     JPEDIT=IPISO(IISOTS)
           IF(.NOT.C_ASSOCIATED(JPEDIT)) GO TO 40
           CALL LCMLEN(JPEDIT,'DECAY',ILONG,ITYLCM)
@@ -403,6 +409,6 @@
       IF(NMAC.GT.0) DEALLOCATE(NOMMAC)
       IF(NREA.GT.0) DEALLOCATE(NOMREA)
       DEALLOCATE(VOLMIX,IPERM,CONCES,DENISO,DEN,WORK2,WORK1,WORKD,DCHI,
-     1 DNUSIG,OVERV,ITYPE,MIX,ISONAM)
+     1 DNUSIG,OVERV,IDEPL,ITYPE,MIX,ISONAM)
       RETURN
       END
diff --git a/Dragon/src/EDIMIC.f b/Dragon/src/EDIMIC.f
index e284110..90e1dfb 100644
--- a/Dragon/src/EDIMIC.f
+++ b/Dragon/src/EDIMIC.f
@@ -172,7 +172,6 @@
       MAXH=9+NBESP+2*NDEL+NED+NL+3*NW
       CALL EDIMAX(NBISO,ISONAM,MIX,IPRINT,NREGIO,NMERGE,MATCOD,IMERGE,
      1 LSISO,LISO,MAXISO)
-      
       ALLOCATE(IGAR(NGROUP,3,NL),IHNISO(3,MAXISO),ISMIX(MAXISO),
      1 ISTYP(MAXISO),ISTOD(MAXISO),ITYPRO(NL),MILVO(NMERGE),
      2 ITYPS(NBISO),IMERGL(NBMIX))
@@ -200,11 +199,9 @@
         IF(MAXISO.GT.0) JPEDIT=LCMLID(IPEDIT,'ISOTOPESLIST',MAXISO)
       ENDIF
 *
-      DO 10 ISO=1,MAXISO
-      SDEN(ISO)=0.0
-      VOLISO(ISO)=0.0
-      JPIFI(ISO)=0
-   10 CONTINUE
+      SDEN(:MAXISO)=0.0
+      VOLISO(:MAXISO)=0.0
+      JPIFI(:MAXISO)=0
       IOF0H=8+NED+NL+3*NW
       IOF1H=8+NED+NL+3*NW+NDEL
       IOF2H=8+NED+NL+3*NW+2*NDEL
@@ -349,24 +346,10 @@
 *  MERGE/CONDENSE REACTIONS 'NWT0','NWT1','NWAT0','NWAT1','SIGS'//CM,
 *   'SCAT'//CM, 'NTOT0', 'NUSIGF', 'CHI', 'CHIxx', 'STRD' AND HVECT
 *----
-      DO 110 J=1,MAXH+NL
-      HMAKE(J)=' '
-  110 CONTINUE
-      DO 121 J=1,MAXH
-      DO 120 I=1,NGCOND
-      GAS(I,J)=0.0D0
-  120 CONTINUE
-  121 CONTINUE
-      DO 132 K=1,NL
-      DO 131 J=1,NGCOND
-      DO 130 I=1,NGCOND
-      WSCAT(I,J,K)=0.0D0
-  130 CONTINUE
-  131 CONTINUE
-  132 CONTINUE
-      DO 140 I=1,NDEL
-      WDLA(I)=0.0
-  140 CONTINUE
+      HMAKE(:MAXH+NL)=' '
+      GAS(:NGCOND,:MAXH)=0.0D0
+      WSCAT(:NGCOND,:NGCOND,:NL)=0.0D0
+      WDLA(:NDEL)=0.0
 *----
 *  RECOVER THE RADIOACTIVE DECAY CONSTANTS OF DELAYED NEUTRON
 *  GROUPS FROM THE MACROLIB IF THEY EXIST
@@ -508,9 +491,7 @@
                CALL LCMGET(KPLIB,'TRANC',GAR(1,7+NED+NL+3*NW))
                HMAKE(7+NED+NL+3*NW)='TRANC'
             ENDIF
-            DO 186 IGR=1,NGROUP
-            GAR(IGR,5+NED+NL+3*NW)=0.0
-  186       CONTINUE
+            GAR(:NGROUP,5+NED+NL+3*NW)=0.0
             CALL LCMLEN(KPLIB,'H-FACTOR',LENGTH,ITYLCM)
             IF(LENGTH.GT.0) THEN
                CALL LCMGET(KPLIB,'H-FACTOR',GAR(1,5+NED+NL+3*NW))
@@ -549,9 +530,7 @@
             PARM4=0.0D0
             PARM12(:NW+1)=0.0D0
             IF(IADJ.EQ.0) THEN
-              DO 206 IW=1,NW+1
-                PARM12(IW)=FLUXES(IREGIO,IGR,IW)*DENVOL
-  206         CONTINUE
+              PARM12(:NW+1)=FLUXES(IREGIO,IGR,:NW+1)*DENVOL
               PARM3=0.0D0
               DO 210 JREGIO=1,NREGIO
               IF(IMERGE(JREGIO).EQ.INM) THEN
diff --git a/Dragon/src/MPOCA2.f b/Dragon/src/MPOCA2.f
index 70a24a8..49ac76d 100644
--- a/Dragon/src/MPOCA2.f
+++ b/Dragon/src/MPOCA2.f
@@ -75,8 +75,8 @@
 *----
 *  ALLOCATABLE ARRAYS
 *----
-      INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATAP,IFD1,IAD1,IFD2,
-     1 IAD2,IJJ1,NJJ1,IPOS,IJJ2,NJJ2,MIX,ITYPE,IDATAP_MIL,VINTE1D
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATAP,IFD1,IAD1,IFD2,IAD2,
+     1 IJJ1,NJJ1,IPOS,IJJ2,NJJ2,MIX,ITYPE,IDEPL,IDATAP_MIL,VINTE1D
       INTEGER, ALLOCATABLE, DIMENSION(:) :: REACTION,ISOTOPE
       INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISONAM,OUPUTID
       INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: ADRX,VINTE3D
@@ -94,7 +94,7 @@
       ALLOCATE(ADRX(NREA+3,NISO,NADRX+NMIL),IDATAP(MAXIDA),IFD1(NG),
      1 IAD1(NG+1),IFD2(NG),IAD2(NG+1),IJJ1(NMIL),NJJ1(NMIL),
      2 IPOS(NMIL),IJJ2(NG),NJJ2(NG),ISONAM(3,NBISO),MIX(NBISO),
-     3 ITYPE(NBISO),IDATAP_MIL((2*NG+1)*NISO))
+     3 ITYPE(NBISO),IDEPL(NBISO),IDATAP_MIL((2*NG+1)*NISO))
       ALLOCATE(RDATAX(MAXRDA),OVERV(NG),DNUSIG(NG,NPRC+1),
      1 DCHI(NG,NPRC),WORKD(NPRC),WORK1(NG*NMIL+1),WORK2(NG),
      2 DATA1(NG,NREA),DATA2(NG,NL),DATA3(NG,NG,NL),DATA4(NG,NG),
@@ -227,6 +227,7 @@
          CALL LCMGET(IPEDIT,'ISOTOPESMIX',MIX)
          CALL LCMGET(IPEDIT,'ISOTOPESDENS',DEN)
          CALL LCMGET(IPEDIT,'ISOTOPESTYPE',ITYPE)
+         CALL LCMGET(IPEDIT,'ISOTOPESTODO',IDEPL)
       ENDIF
       NISOTS=0
       DO 90 IBISO=1,NBISO
@@ -287,6 +288,7 @@
         ALLOCATE(DECAYC(NISOTS))
         DECAYC(:NISOTS)=0.0
         DO 150 IBISO=1,NBISO
+        IF(IDEPL(IBISO).EQ.1) GO TO 150
         IF(MIX(IBISO).EQ.0) GO TO 150
         WRITE(TEXT12,'(3A4)') (ISONAM(I0,IBISO),I0=1,3)
         IISOTS=0
@@ -1007,7 +1009,7 @@
       DEALLOCATE(NOMISO,NOMREA)
       DEALLOCATE(CONCES,DENISO,DEN,DATA4,DATA3,DATA2,DATA1,WORK2,WORK1,
      1 WORKD,DCHI,DNUSIG,OVERV,RDATAX)
-      DEALLOCATE(IDATAP_MIL,ITYPE,MIX,ISONAM,NJJ2,IJJ2,IPOS,NJJ1,IJJ1,
-     1 IAD2,IFD2,IAD1,IFD1,IDATAP,ADRX)
+      DEALLOCATE(IDATAP_MIL,IDEPL,ITYPE,MIX,ISONAM,NJJ2,IJJ2,IPOS,NJJ1,
+     1 IJJ1,IAD2,IFD2,IAD1,IFD1,IDATAP,ADRX)
       RETURN
       END