Initial commit from Polytechnique Montreal

1 files changed, 502 insertions, 0 deletions

diff --git a/Dragon/src/XELMRG.f b/Dragon/src/XELMRG.f
new file mode 100644
index 0000000..06134f2
--- /dev/null
+++ b/Dragon/src/XELMRG.f
@@ -0,0 +1,502 @@
+*DECK XELMRG
+      SUBROUTINE XELMRG (  IPRT,   NSUR,   NVOL,   NSBC, NTOTCL, INDEX,
+     >                   MINDIM, MAXDIM, LCLSYM, LCLTRA,    LL1,   LL2,
+     >                   MRGCEL, MATALB, KEYMRG, INCELL, MATRT)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Construct keymrg according to implicit merging imposed by the 
+* boundary conditions.
+*
+*Copyright:
+* Copyright (C) 1990 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): R. Roy
+*
+*Parameters: input
+* IPRT    printing level.                               
+* NSUR    number of surfaces.                               
+* NVOL    number of zones.                                  
+* NSBC    number of surfaces with independent BC.           
+* NTOTCL  number of cylindres+3.                            
+* INDEX   numbering of surfaces and zones.                  
+* MINDIM  minimum index values for all axes (rect/cyl). 
+* MAXDIM  maximum index values for all axes (rect/cyl).
+* LCLSYM  symmetry flags (0: no; -1/+1: syme; -2/+2: ssym). 
+* LCLTRA  translation flags (0: no; -1/+1: tra).           
+* LL1     diagonal symmetry (2,3).                     
+* LL2     diagonal symmetry (1,4).                      
+* MRGCEL  merging cell numbering.                           
+* MATALB  material types.                              
+*
+*Parameters: input/output
+* KEYMRG  initial numbering at input, merged at output.     
+* INCELL  block   numbering at input, merged at output.     
+*
+*Parameters: output
+* MATRT   reflection/transmission vector.
+*
+*-----------------------------------------------------------------------
+*
+      IMPLICIT     NONE
+*
+      INTEGER      IPRT,   NSUR,   NVOL,   NSBC, NTOTCL
+      INTEGER      LCLSYM(3), LCLTRA(3), IORD(4), INDEX(4,*), KEYMRG(*),
+     >             MATALB(*), MINDIM(NTOTCL), MAXDIM(NTOTCL), INCELL(*),
+     >             MRGCEL(*), MATRT(-NSUR,2)
+      LOGICAL      LL1, LL2
+*
+      LOGICAL      SWOK, SWSUR, SWSTOP
+      INTEGER      NUM, I, ISUR, ITRA, IVS1, IVS2, ISYM, IORD4, ICC1,
+     >             INDEX4, INCR, NO1, NO2, IB1, IB2, NZSU, NZVO, NZABS,
+     >             NMBLK, IBLK, NZBLK, IMRG, MINV, MAXV, NVOLM, NSURM,
+     >             ICMP1, ICMP2, ITRAC1, NSURC, IP, IR, NVOLC, NMVO
+      CHARACTER*4  CORIEN(-6:0)
+      INTEGER      IOUT
+      PARAMETER  ( IOUT=6 )
+*
+      DATA              CORIEN
+     >        / ' Z+ ',' Z- ',' Y+ ',' Y- ',' X+ ',' X- ','    ' /
+*
+      NUM(I)= I + 1 - NSUR
+*
+*     INITIALIZE MATRT TO REFLECTION FOR ORIGINAL SURFACES
+      NVOLM=0
+      DO 300 ISUR=1, -NSUR
+        MATRT(ISUR,1)=0
+        MATRT(ISUR,2)=ISUR
+ 300  CONTINUE
+*
+*  0) TREAT TRANSLATION SYMMETRIES *************************************
+      DO 310 ITRA =1,3
+        IF( LCLTRA(ITRA) .EQ. 1) THEN
+          DO 320 IVS1 = NSUR, -1
+            IF( (KEYMRG(NUM(IVS1)) .NE.  0   ) .AND.
+     >          (MATRT(-IVS1,2)    .EQ. -IVS1)       ) THEN
+*
+*             LOCATE SURFACE IN X, Y, Z AND R
+              IORD(1)= INDEX(1,NUM(IVS1))
+              IORD(2)= INDEX(2,NUM(IVS1))
+              IORD(3)= INDEX(3,NUM(IVS1))
+              IORD(4)= INDEX(4,NUM(IVS1))
+*
+*             LOCATE TRANSLATED SURFACE IN X, Y, Z AND R
+              IF( (IORD(ITRA) .GE. MINDIM(ITRA)) .AND.
+     >            (IORD(ITRA) .LT. MAXDIM(ITRA)) ) GO TO 345
+              IORD(ITRA)= (MAXDIM(ITRA)+MINDIM(ITRA))-(IORD(ITRA)+1)
+*              INDEX(1,NUM(0))= IORD(1)
+*              INDEX(2,NUM(0))= IORD(2)
+*              INDEX(3,NUM(0))= IORD(3)
+*              INDEX(4,NUM(0))= IORD(4)
+*
+*             FOR CYLINDERS, *IORD4* IS ABSOLUTE.
+              IORD4 = IORD(4)
+              IF(IORD(4) .NE. 0 )THEN
+                DO 330 ICC1= NTOTCL, 4, -1
+                  IF( IORD(4) .LT. MAXDIM(ICC1) )THEN
+                    IORD4 = IORD(4)-MINDIM(ICC1)
+                  ENDIF
+  330           CONTINUE
+              ENDIF
+              DO 340 IVS2=NSUR,-1
+                IF( IORD(1) .EQ. INDEX(1,NUM(IVS2)).AND.
+     >              IORD(2) .EQ. INDEX(2,NUM(IVS2)).AND.
+     >              IORD(3) .EQ. INDEX(3,NUM(IVS2))      ) THEN
+                  INDEX4= INDEX(4,NUM(IVS2))
+                  IF( IORD(4).NE.0 )THEN
+                    DO 350 ICC1= NTOTCL, 4, -1
+                      IF( INDEX(4,NUM(IVS2)).LT.MAXDIM(ICC1) )THEN
+                        INDEX4= INDEX(4,NUM(IVS2))-MINDIM(ICC1)
+                      ENDIF
+  350               CONTINUE
+                  ENDIF
+*
+*                 SYMMETRIC SURFACE LOCATED FOR TRANSMISSION BC
+*                 STORE SURFACES IDENTIFIER IN MATRT AND
+*                 EXIT TO 345
+                  IF( INDEX4.EQ.IORD4) THEN
+                    MATRT(-IVS1,2)=-IVS2
+                    MATRT(-IVS2,2)=-IVS1
+                    GO TO 345
+                  ENDIF
+                ENDIF
+ 340          CONTINUE
+              CALL XABORT( 'XELMRG: TRANSLATED SURFACE NO FOUND.' )
+            ENDIF
+ 345        CONTINUE
+ 320      CONTINUE
+        ENDIF
+ 310  CONTINUE
+*
+*  1) TREAT AXIAL SYMMETRIES ******************************************
+      DO 20 ISYM= 1, 3
+         IF( LCLSYM(ISYM).NE.0 )THEN
+            DO 10 IVS1= NSUR, NVOL
+*
+*              FOR REGIONS ABSENT FROM FINAL CELL
+*              DO NOT BOTHER TO SYMMETRIZE
+               IF( IVS1 .EQ. 0 .OR. KEYMRG(NUM(IVS1)) .EQ. 0) GO TO 10
+               IORD(1)= INDEX(1,NUM(IVS1))
+               IORD(2)= INDEX(2,NUM(IVS1))
+               IORD(3)= INDEX(3,NUM(IVS1))
+               IORD(4)= INDEX(4,NUM(IVS1))
+*
+*  1.1)        RECOMPOSE *ISYM* VALUE TO  GET THE SYMMETRIC COORDINATE
+               IORD(ISYM)= (MAXDIM(ISYM)+MINDIM(ISYM))-(IORD(ISYM)+1)
+               IF( IVS1.GT.0 )THEN
+                  IVS2= NVOL
+                  INCR= -1
+               ELSE
+                  IVS2= NSUR
+                  INCR= +1
+               ENDIF
+*               INDEX(1,NUM(0))= IORD(1)
+*               INDEX(2,NUM(0))= IORD(2)
+*               INDEX(3,NUM(0))= IORD(3)
+*               INDEX(4,NUM(0))= IORD(4)
+*
+*  1.2)        TO SEARCH FOR THE GOOD CYLINDER, *IORD4* IS ABSOLUTE.
+               IORD4 = IORD(4)
+               IF( IORD(4).NE.0 )THEN
+                  DO 110 ICC1= NTOTCL, 4, -1
+                     IF( IORD(4).LT.MAXDIM(ICC1) )THEN
+                        IORD4 = IORD(4)-MINDIM(ICC1)
+                     ENDIF
+  110             CONTINUE
+               ENDIF
+   11          CONTINUE
+                  IF( IORD(1).EQ.INDEX(1,NUM(IVS2)).AND.
+     >                IORD(2).EQ.INDEX(2,NUM(IVS2)).AND.
+     >                IORD(3).EQ.INDEX(3,NUM(IVS2)) )THEN
+                     INDEX4= INDEX(4,NUM(IVS2))
+                     IF( IORD(4).NE.0 )THEN
+                        DO 112 ICC1= NTOTCL, 4, -1
+                           IF( INDEX(4,NUM(IVS2)).LT.MAXDIM(ICC1) )THEN
+                              INDEX4= INDEX(4,NUM(IVS2))-MINDIM(ICC1)
+                           ENDIF
+  112                   CONTINUE
+                     ENDIF
+                     IF( INDEX4.EQ.IORD4) GO TO 12
+                  ENDIF
+                  IVS2= IVS2 + INCR
+               GO TO 11
+   12          IF( IVS2.EQ.0 )THEN
+                  CALL XABORT( 'XELMRG: RARE AXIAL SYMMETRY PROBLEM.' )
+               ENDIF
+               NO1= KEYMRG(NUM(IVS1))
+               NO2= KEYMRG(NUM(IVS2))
+               IB1= INCELL(NUM(IVS1))
+               IB2= INCELL(NUM(IVS2))
+*
+*  1.3)        SELECT THE MAX OR MIN VALUE TO CORRECTLY # ZONES
+               IF( LCLSYM(ISYM).GT.0 )THEN
+                  KEYMRG(NUM(IVS1))= MIN(NO1,NO2)
+                  KEYMRG(NUM(IVS2))= MIN(NO1,NO2)
+                  INCELL(NUM(IVS1))= MIN(IB1,IB2)
+                  INCELL(NUM(IVS2))= MIN(IB1,IB2)
+               ELSE
+                  KEYMRG(NUM(IVS1))= MAX(NO1,NO2)
+                  KEYMRG(NUM(IVS2))= MAX(NO1,NO2)
+                  INCELL(NUM(IVS1))= MAX(IB1,IB2)
+                  INCELL(NUM(IVS2))= MAX(IB1,IB2)
+               ENDIF
+   10       CONTINUE
+         ENDIF
+   20 CONTINUE
+*
+*  2) TREAT DIAGONAL SYMMETRIES ***************************************
+*                       (SIDE #3)
+*               (SIDE #1) GEOM  (SIDE #2)
+*                       (SIDE #4)
+*
+      IF( LL1.OR.LL2 )THEN
+         DO 30 IVS1= NSUR, NVOL
+*
+*           FOR REGIONS ABSENT FROM FINAL CELL
+*           DO NOT BOTHER TO SYMMETRIZE
+            IF( IVS1 .EQ. 0 .OR. KEYMRG(NUM(IVS1)) .EQ. 0 ) GO TO 30
+*
+*  2.1)        FOR (SIDE #1).EQ.(SIDE #4)
+*              AND (SIDE #2).EQ.(SIDE #3) *** DIAGONAL SYMMETRY (\) ***
+*           NOTE: ***NOT*** ACCEPTED IN DRAGON.
+***         IORD(1)= (MAXDIM(2)+MINDIM(1)) - (INDEX(2,NUM(IVS1))+1)
+***         IORD(2)= (MAXDIM(1)+MINDIM(2)) - (INDEX(1,NUM(IVS1))+1)
+*  2.2)        FOR (SIDE #2).EQ.(SIDE #4)
+*              AND (SIDE #1).EQ.(SIDE #3) *** DIAGONAL SYMMETRY (/) ***
+            IORD(1)= INDEX(2,NUM(IVS1)) + MINDIM(1) - MINDIM(2)
+            IORD(2)= INDEX(1,NUM(IVS1)) + MINDIM(2) - MINDIM(1)
+            IORD(3)= INDEX(3,NUM(IVS1))
+            IORD(4)= INDEX(4,NUM(IVS1))
+            IF( IVS1.GT.0 )THEN
+               IVS2= NVOL
+               INCR= -1
+            ELSE
+               IVS2= NSUR
+               INCR= +1
+            ENDIF
+*            INDEX(1,NUM(0))= IORD(1)
+*            INDEX(2,NUM(0))= IORD(2)
+*            INDEX(3,NUM(0))= IORD(3)
+*            INDEX(4,NUM(0))= IORD(4)
+            IORD4 = IORD(4)
+            IF( IORD(4).NE.0 )THEN
+               DO 33 ICC1= NTOTCL, 4, -1
+                  IF( IORD(4).LT.MAXDIM(ICC1) )THEN
+                     IORD4 = IORD(4)-MINDIM(ICC1)
+                  ENDIF
+   33          CONTINUE
+            ENDIF
+   31       CONTINUE
+               IF( IORD(1).EQ.INDEX(1,NUM(IVS2)).AND.
+     >             IORD(2).EQ.INDEX(2,NUM(IVS2)).AND.
+     >             IORD(3).EQ.INDEX(3,NUM(IVS2)) )THEN
+                  INDEX4= INDEX(4,NUM(IVS2))
+                  IF( IORD(4).NE.0 )THEN
+                     DO 34 ICC1= NTOTCL, 4, -1
+                        IF( INDEX(4,NUM(IVS2)).LT.MAXDIM(ICC1) )THEN
+                           INDEX4= INDEX(4,NUM(IVS2))-MINDIM(ICC1)
+                        ENDIF
+   34                CONTINUE
+                  ENDIF
+                  IF( INDEX4.EQ.IORD4) GO TO 32
+               ENDIF
+               IVS2= IVS2 + INCR
+            GO TO 31
+   32       IF( IVS2.EQ.0 )THEN
+               CALL XABORT( 'XELMRG: RARE DIAGONAL SYMMETRY PROBLEM.' )
+            ENDIF
+            NO1= KEYMRG(NUM(IVS1))
+            NO2= KEYMRG(NUM(IVS2))
+            IB1= INCELL(NUM(IVS1))
+            IB2= INCELL(NUM(IVS2))
+*
+*  2.3)        SELECT THE MAX OR MIN VALUE TO CORRECTLY # ZONES
+            IF( LL2 )THEN
+               KEYMRG(NUM(IVS1))= MIN(NO1,NO2)
+               KEYMRG(NUM(IVS2))= MIN(NO1,NO2)
+               INCELL(NUM(IVS1))= MIN(IB1,IB2)
+               INCELL(NUM(IVS2))= MIN(IB1,IB2)
+            ELSE
+               KEYMRG(NUM(IVS1))= MAX(NO1,NO2)
+               KEYMRG(NUM(IVS2))= MAX(NO1,NO2)
+               INCELL(NUM(IVS1))= MAX(IB1,IB2)
+               INCELL(NUM(IVS2))= MAX(IB1,IB2)
+            ENDIF
+   30    CONTINUE
+      ENDIF
+*
+*  3) NOW, STOCK NEW INCREASING VALUES IN *KEYMRG* AND *INCELL* ********
+      NZSU= 0
+      DO 40 IVS1= -1, NSUR,-1
+        DO 41 IVS2= -1, NSUR, -1
+*
+*  3.1.1) COUNT THE NUMBER OF SURFACES.
+          IF( KEYMRG(NUM(IVS2)).EQ.IVS1 )THEN
+            NZSU= NZSU-1
+            GO TO 40
+          ENDIF
+   41   CONTINUE
+   40 CONTINUE
+      NZVO=0
+      DO 42 IVS1= 1, NVOL
+        DO 43 IVS2= 1, NVOL
+*
+*  3.1.2) COUNT THE NUMBER OF VOLUMES.
+          IF( KEYMRG(NUM(IVS2)).EQ.IVS1 )THEN
+            NZVO= NZVO+1
+            GO TO 42
+          ENDIF
+   43   CONTINUE
+   42 CONTINUE
+      NZABS= -1
+      DO 50 IVS1= -1, NSUR, -1
+        SWOK= .FALSE.
+        DO 51 IVS2= -1, NSUR, -1
+*
+*  3.2.1) RENUMBER SURFACES.
+          IF( KEYMRG(NUM(IVS2)).EQ.IVS1 )THEN
+            SWOK= .TRUE.
+            KEYMRG(NUM(IVS2))= NZABS
+          ENDIF
+   51   CONTINUE
+        IF( SWOK )THEN
+          NZABS= NZABS - 1
+        ENDIF
+   50 CONTINUE
+      IF( NZABS.NE.NZSU-1 )THEN
+         CALL XABORT( 'XELMRG: PROBLEMS TO MERGE SURFACES' )
+      ENDIF
+      KEYMRG(NUM(0))= 0
+      NZABS=  1
+      DO 52 IVS1= 1, NVOL
+        SWOK= .FALSE.
+        DO 53 IVS2= 1, NVOL
+*
+*  3.2.2) RENUMBER VOLUMES.
+          IF( KEYMRG(NUM(IVS2)).EQ.IVS1 )THEN
+            SWOK= .TRUE.
+            KEYMRG(NUM(IVS2))= NZABS
+          ENDIF
+   53   CONTINUE
+        IF( SWOK )THEN
+          NZABS= NZABS + 1
+        ENDIF
+   52 CONTINUE
+      IF( NZABS.NE.NZVO+1 )THEN
+         CALL XABORT( 'XELMRG: PROBLEMS TO MERGE VOLUMES' )
+      ENDIF
+      NMBLK= 0
+      DO 60 IVS2= NSUR, NVOL
+*
+*  3.3) COUNT NUMBER OF BLOCKS.
+        IF( KEYMRG(NUM(IVS2)).NE.0 )THEN
+          IBLK=INCELL(NUM(IVS2))
+          IF( IBLK.NE.0 )THEN
+            NMBLK=MAX(NMBLK,IBLK)
+          ENDIF
+        ENDIF
+   60 CONTINUE
+      NZBLK= 1
+      DO 70 IBLK= 1, NMBLK
+        SWOK= .FALSE.
+        DO 71 IVS2= NSUR, NVOL
+*
+*  3.4)   RENUMBER BLOCKS.
+          IF( KEYMRG(NUM(IVS2)).NE.0 )THEN
+            IF( INCELL(NUM(IVS2)).EQ.IBLK )THEN
+              SWOK= .TRUE.
+              INCELL(NUM(IVS2))= NZBLK
+            ENDIF
+          ENDIF
+   71   CONTINUE
+        IF( SWOK )THEN
+          NZBLK= NZBLK + 1
+        ENDIF
+   70 CONTINUE
+      NZBLK= NZBLK-1
+      IF( NZBLK .LE. 0 .OR. NZBLK .GT. NMBLK)THEN
+         CALL XABORT( 'XELMRG: PROBLEMS TO MERGE BLOCKS' )
+      ENDIF
+*
+*  3.5) RENUMBER CELL BLOCKS ACCORDING TO THE MERGE INDEX *MRGCEL*
+*     *** THIS WILL RENUMBER VOLUMES, BUT NOT SURFACES. ***
+      NMVO = 0
+      NMBLK= 1
+      SWSTOP= .FALSE.
+      DO 290 IMRG= 1, NZBLK
+        SWOK= .FALSE.
+        DO 280 IBLK=1, NZBLK
+          IF( MRGCEL(IBLK).EQ.IMRG )THEN
+            IF( IMRG.NE.NMBLK )
+     >         CALL XABORT('XELMRG: INCREASING MERGE #ING REQUIRED')
+            MINV= +100000000
+            MAXV= 0
+            SWSUR=.FALSE.
+            DO 210 IVS1= 1, NVOL
+              IF(KEYMRG(NUM(IVS1)).GT.0) THEN
+                IF( INCELL(NUM(IVS1)).EQ.IBLK )THEN
+                  MINV= MIN(MINV,KEYMRG(NUM(IVS1)))
+                  MAXV= MAX(MAXV,KEYMRG(NUM(IVS1)))
+                ENDIF
+              ENDIF
+  210       CONTINUE
+            IF( SWOK )THEN
+              SWSTOP= SWSTOP.OR.(NVOLM.NE.MAXV+1-MINV)
+            ELSE
+              NVOLM = MAXV+1-MINV
+            ENDIF
+            MINV= MINV-NMVO
+            DO 220 IVS1= 1, NVOL
+              IF(KEYMRG(NUM(IVS1)).GT.0) THEN
+                IF( INCELL(NUM(IVS1)).EQ.IBLK )THEN
+                  KEYMRG(NUM(IVS1))= KEYMRG(NUM(IVS1))-(MINV-1)
+                ENDIF
+              ENDIF
+  220       CONTINUE
+            SWOK= .TRUE.
+          ENDIF
+  280   CONTINUE
+        IF( SWOK )THEN
+          NMVO= NMVO+NVOLM
+          NMBLK= NMBLK+1
+        ENDIF
+  290 CONTINUE
+      NMBLK= NMBLK-1
+      NSBC=-NZSU
+*
+*  4) RESET *MATRT* FOR MERGED SURFACES INSTEAD OF ORIGINAL SURFACES ***
+      NZSU=0
+      DO 360 IVS1=-1,NSUR,-1
+        ICMP1=KEYMRG(NUM(IVS1))
+        IVS2=-MATRT(-IVS1,2)
+        ICMP2=KEYMRG(NUM(IVS2))
+        IF( (ICMP1 .LT. 0) .AND. (ICMP2 .LT. 0) ) THEN
+          ITRAC1=MATRT(-ICMP1,1)
+          IF(ITRAC1 .EQ. 0) THEN
+            MATRT(-ICMP1,1)=-ICMP2
+            MATRT(-ICMP2,1)=-ICMP1
+          ENDIF
+        ENDIF
+ 360  CONTINUE
+*
+*  5) PRINTING *********************************************************
+      IF( IPRT.GT.2 )THEN
+         NSURC = -1
+         WRITE(IOUT,'(1H )')
+         WRITE(IOUT,'(/40H  SURFACE #ING ( BEFORE CELL MERGE )     )')
+         DO 580 IP  = 1, (9 - NSUR) / 10
+            NSURM= MAX( NSUR, NSURC-9 )
+            WRITE(IOUT,'(10X,10(A5,I7))')
+     >           (' SUR ',-IR,IR= NSURC, NSURM, -1)
+            WRITE(IOUT,'(8H ORIENT ,2X,10A12)')
+     >           (CORIEN(MATALB(NUM(IR))),IR=NSURC,NSURM,-1)
+            WRITE(IOUT,'(8H CELL # ,2X,10I12)')
+     >           (INCELL(NUM(IR)),IR=NSURC,NSURM,-1)
+            WRITE(IOUT,'(9H MERGE TO ,1X,10(A5,I7))')
+     >           (' SUR ',-KEYMRG(NUM(IR)),IR=NSURC,NSURM,-1)
+            WRITE(IOUT,'(1H )')
+            NSURC = NSURC - 10
+  580    CONTINUE
+         NVOLC= 1
+         WRITE(IOUT,'(1H )')
+         WRITE(IOUT,'( 40H  VOLUME  #ING ( BEFORE CELL MERGE )      )')
+         DO 590 IP  = 1, (9 + NVOL) / 10
+            NVOLM= MIN( NVOL, NVOLC+9 )
+            WRITE(IOUT,'(10X,10(A5,I7))')
+     >               (' VOL ',IR,IR=NVOLC,NVOLM, 1)
+            WRITE(IOUT,'(8H CELL # ,2X,10I12)')
+     >           (INCELL(NUM(IR)),IR=NVOLC,NVOLM, 1)
+            WRITE(IOUT,'(9H MERGE TO ,1X,10(A5,I7))')
+     >           (' VOL ', KEYMRG(NUM(IR)),IR=NVOLC,NVOLM, 1)
+            WRITE(IOUT,'(8H MIX    ,2X,10I12)')
+     >           (MATALB(NUM(IR)),IR=NVOLC,NVOLM, 1)
+            WRITE(IOUT,'(9H          ,1X,10(A5,I7))')
+     >           (' CELL',MRGCEL(INCELL(NUM(IR))),IR=NVOLC,NVOLM, 1)
+            WRITE(IOUT,'(1H )')
+            NVOLC = NVOLC + 10
+  590    CONTINUE
+         WRITE(IOUT,'( 40H  BC MATRIX (BEFORE MERGE)                )')
+         WRITE(IOUT,'(8(5X,I10,I10))') (IR,MATRT(IR,2),IR=1,-NSUR)
+         WRITE(IOUT,'( 40H  BC MATRIX (AFTER MERGE)                 )')
+         WRITE(IOUT,'(8(5X,I10,I10))') (IR,MATRT(IR,1),IR=1,NSBC)
+      ELSEIF( IPRT.GT.1 )THEN
+         WRITE(IOUT,'(1H )')
+         WRITE(IOUT,'(32H # OF SURFACES AFTER SYMMETRIES: ,I8)') -NZSU
+         WRITE(IOUT,'(32H # OF ZONES    AFTER SYMMETRIES: ,I8)')  NZVO
+         WRITE(IOUT,'(32H # OF CELLS    AFTER SYMMETRIES: ,I8)')  NZBLK
+         WRITE(IOUT,'(1H )')
+         WRITE(IOUT,'(32H # OF ZONES    AFTER MERGING   : ,I8)')  NMVO
+         WRITE(IOUT,'(32H # OF CELLS    AFTER MERGING   : ,I8)')  NMBLK
+         WRITE(IOUT,'(1H )')
+      ENDIF
+      IF( SWSTOP )THEN
+         CALL XABORT('XELMRG: MERGE CELL ONLY WITH SAME # OF ZONES')
+      ENDIF
+*
+      RETURN
+      END