*DECK NUMERH
      SUBROUTINE NUMERH (NCOUR,MULTC,NCODE,ZCODE,IHEX,LX,LZ,IORI,ISM,
     1 POURCE,IMPX,NMBLK,IFR,ALB,NMERGE,INUM,MIX,DVX,NGEN,IGEN,XX,ZZ)
*
*-----------------------------------------------------------------------
*
*Purpose:
* surface renumbering algorithm for hexagonal geometry.
* The 3-D DP-1 approximation is not implemented.
*
*Copyright:
* Copyright (C) 2002 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/output
* NCOUR   number of surfaces per block (input); number of out-currents
*         per block (output).
* MULTC   type of multicell approximation:
*         =1: Roth;    =2: Roth X ncour;    =3: DP-0;    =4: DP-1.
* NCODE   type of boundary condition on each side of the domain:
*         =0: not used;   =1: VOID;     =2: REFL;
*         =3: not used;   =4: TRAN;     =5: SYME.
* ZCODE   value of the albedo on each side of the domain (only
*         components 1, 5 and 6 are used).
* IHEX    type of symmetry:
*         =1: S30;   =2: SA60;   =3: SB60;   =4: S90;   =5: R120;
*         =6: R180;  =7: SA180;  =8: SB180;  =9: COMPLETE.
* LX      number of blocks in the X-Y (hexagonal) plane.
* LZ      number of blocks along the Z-axis.
* IORI    orientation of the blocks.
* ISM     permutation index corresponding to each orientation
*         (ISM(I,N)=I is the natural orientation).
* POURCE  weight associated with each merged block.
* IMPX    print flag (equal to 0 for no print).
* NMBLK   total number of blocks in the domain.
* IFR     index-number of in-currents.
* ALB     transmission/albedo associated with each in-current.
* NMERGE  total number of merged cells for which specific values
*         of the neutron flux and reactions rates are required.
*         Many cells with different position in the domain can
*         be merged before the neutron flux calculation if they
*         own the same generating cell (NMERGE.le.NMBLK).
* INUM    index-number of the merged cell associated to each cell.
* MIX     index-number of out-currents.
* DVX     weight associated with each out-current.
*         Note: IFR, ALB, MIX and DVX contains information to rebuild
*         the geometrical 'A' matrix.
* NGEN    total number of generating blocks in the cartesian domain.
* IGEN    index-number of the generating block associated with each
*         merged block.
* XX      side of the generating hexagons.
* ZZ      Z-thickness of the generating blocks (hexagons).
*
*-----------------------------------------------------------------------
*
*----
*  SUBROUTINE ARGUMENTS
*----
      INTEGER NCOUR,MULTC,NCODE(6),IHEX,LX,LZ,IORI(NMBLK),ISM(8,12),
     1 IMPX,NMBLK,IFR(18*NMBLK),NMERGE,INUM(NMBLK),MIX(18*NMERGE),
     2 NGEN,IGEN(NMERGE)
      REAL ZCODE(6),POURCE(NMERGE),ALB(18*NMBLK),DVX(18*NMERGE),
     1 XX(NGEN),ZZ(NGEN)
*----
*  LOCAL VARIABLES
*----
      PARAMETER (EPS=1.0E-5)
      LOGICAL LOG1,LTRAN
      CHARACTER DIRR(8)*2,DIRZ(18)*2,HSMG*131
      INTEGER ICCC(6),IDDD(8),ISMZ(18)
      REAL DDD(8)
      INTEGER, ALLOCATABLE, DIMENSION(:) :: JF2
      REAL, ALLOCATABLE, DIMENSION(:) :: GG3
      SAVE DIRR
      DATA DIRR/'H1','H2','H3','H4','H5','H6','Z-','Z+'/
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(JF2(8*NMBLK),GG3(NMBLK))
*
      DO 5 I=1,NCOUR*NMERGE
      MIX(I)=I
5     DVX(I)=1.0
      LTRAN=(IHEX.EQ.5).OR.(IHEX.EQ.6)
      ZALB=1.0
      IF(NCODE(1).EQ.1) ZALB=ZCODE(1)
      IBLK=0
      DO 50 K0=1,LZ
      DO 50 K1=1,LX
      IBLK=IBLK+1
      IKK=INUM(IBLK)
      FRZ=1.0
      IF(IKK.EQ.0) GO TO 50
      IS=NCOUR*(IBLK-1)
      IT=NCOUR*(IKK-1)
      II=IORI(IBLK)
      DO 10 IC=1,NCOUR
      IDDD(IC)=-1
      ALB(IS+IC)=1.0
      IF(IC.LE.6) THEN
         ICCC(IC)=NEIGHB(K1,IC,IHEX,LX,FRX)
         IF((ICCC(IC).GT.0).AND.(ICCC(IC).NE.K1).AND.(ICCC(IC).LE.LX))
     1   IDDD(IC)=ICCC(IC)+(K0-1)*LX
      ELSE IF((IC.EQ.7).AND.(K0.GT.1)) THEN
         IDDD(7)=IBLK-LX
      ELSE IF((IC.EQ.8).AND.(K0.LT.LZ)) THEN
         IDDD(8)=IBLK+LX
      ENDIF
      JBLK=IDDD(IC)
      IF(JBLK.GT.0) THEN
         JKK=INUM(JBLK)
         JT=NCOUR*(JKK-1)
         IF((IC.LE.6).AND.(JKK.GT.0)) THEN
            IFR(IS+ISM(IC,II))=JT+ISM(1+MOD(IC+2,6),IORI(JBLK))
         ELSE IF((IC.EQ.7).AND.(JKK.GT.0)) THEN
            IFR(IS+ISM(7,II))=JT+ISM(8,IORI(JBLK))
         ELSE IF((IC.EQ.8).AND.(JKK.GT.0)) THEN
            IFR(IS+ISM(8,II))=JT+ISM(7,IORI(JBLK))
         ELSE
            IFR(IS+ISM(IC,II))=0
         ENDIF
         IDDD(IC)=JKK
      ELSE
         IFR(IS+ISM(IC,II))=0
      ENDIF
10    CONTINUE
      IF(IMPX.GT.10) WRITE(6,610) K1,(ICCC(IC),IC=1,6),FRX
*----
*  VOID OR REFL BOUNDARY CONDITIONS
*----
      DO 15 IC=1,6
      IF(ICCC(IC).GT.LX) THEN
         ALB(IS+ISM(IC,II))=-ZALB
         IFR(IS+ISM(IC,II))=IT+ISM(IC,II)
      ELSE IF(ICCC(IC).EQ.K1) THEN
         ALB(IS+ISM(IC,II))=-1.0
         IFR(IS+ISM(IC,II))=IT+ISM(IC,II)
      ENDIF
15    CONTINUE
      LOG1=(K0.EQ.1).OR.(IDDD(7).EQ.0)
      IF(LOG1.AND.(NCODE(5).EQ.1)) THEN
         ALB(IS+ISM(7,II))=-ZCODE(5)
         IFR(IS+ISM(7,II))=IT+ISM(7,II)
      ELSE IF(LOG1.AND.(NCODE(5).EQ.2)) THEN
         ALB(IS+ISM(7,II))=-1.0
         IFR(IS+ISM(7,II))=IT+ISM(7,II)
      ENDIF
      LOG1=(K0.EQ.LZ).OR.(IDDD(8).EQ.0)
      IF(LOG1.AND.(NCODE(6).EQ.1)) THEN
         ALB(IS+ISM(8,II))=-ZCODE(6)
         IFR(IS+ISM(8,II))=IT+ISM(8,II)
      ELSE IF(LOG1.AND.(NCODE(6).EQ.2)) THEN
         ALB(IS+ISM(8,II))=-1.0
         IFR(IS+ISM(8,II))=IT+ISM(8,II)
      ENDIF
*----
*  CORRECT THE PARITY OF THE INTERFACE CURRENTS FOR DP-1 CASES WITH
*  'MIRROR' ORIENTATION
*----
      DO 20 IC=1,NCOUR
      IF(II.GE.7) ALB(IS+IC)=-ALB(IS+IC)
      JBLK=IBLK
      IF(IC.LE.6) THEN
         IF((ICCC(IC).GT.0).AND.(ICCC(IC).NE.K1).AND.(ICCC(IC).LE.LX))
     1   JBLK=ICCC(IC)+(K0-1)*LX
      ELSE IF((IC.EQ.7).AND.(K0.GT.1)) THEN
         JBLK=IBLK-LX
      ELSE IF((IC.EQ.8).AND.(K0.LT.LZ)) THEN
         JBLK=IBLK+LX
      ENDIF
      IF(IORI(JBLK).GE.7) ALB(IS+ISM(IC,II))=-ALB(IS+ISM(IC,II))
20    CONTINUE
*----
*  TRAN BOUNDARY CONDITION
*----
      DO 30 IC=1,6
      IF(LTRAN.AND.(ICCC(IC).LT.0)) THEN
         JBLK=-ICCC(IC)+(K0-1)*LX
         JT=NCOUR*(INUM(JBLK)-1)
         K1M=-K1
         IF(K1.EQ.1) K1M=1
         JC=0
         DO 25 KC=1,6
         IF(NEIGHB(-ICCC(IC),KC,IHEX,LX,FRW).EQ.K1M) JC=KC
25       CONTINUE
         IF(JC.EQ.0) CALL XABORT('NUMERH: FAILURE NB. 1.')
         IFR(IS+ISM(IC,II))=JT+ISM(JC,IORI(JBLK))
      ENDIF
30    CONTINUE
      IF((K0.EQ.1).AND.(NCODE(5).EQ.4)) THEN
         JBLK=IBLK+(LZ-1)*LX
         IFR(IS+ISM(7,II))=NCOUR*(INUM(JBLK)-1)+ISM(8,IORI(JBLK))
      ENDIF
      IF((K0.EQ.LZ).AND.(NCODE(6).EQ.4)) THEN
         JBLK=IBLK-(LZ-1)*LX
         IFR(IS+ISM(8,II))=NCOUR*(INUM(JBLK)-1)+ISM(7,IORI(JBLK))
      ENDIF
*----
*  SYME BOUNDARY CONDITION
*----
      DO 40 IC=1,6
      IF((.NOT.LTRAN).AND.(ICCC(IC).LT.0)) THEN
         JC=0
         DO 35 KC=1,6
         IF(-ICCC(IC).EQ.ICCC(KC)) JC=KC
35       CONTINUE
         IF(JC.EQ.0) CALL XABORT('NUMERH: FAILURE NB. 2.')
         ZSIGN=-1.0
         IF(K1.EQ.1) THEN
            IF((IHEX.EQ.3).AND.(IC.EQ.3)) ZSIGN=1.0
            IF((IHEX.EQ.3).AND.(IC.EQ.5)) ZSIGN=1.0
            IF((IHEX.EQ.4).AND.(IC.EQ.4)) ZSIGN=1.0
         ENDIF
         IF((IHEX.EQ.10).AND.(FRX.EQ.0.25).AND.(IC.EQ.6)) ZSIGN=1.0
         ALB(IS+ISM(IC,II))=ALB(IS+ISM(JC,II))*ZSIGN
         IFR(IS+ISM(IC,II))=IFR(IS+ISM(JC,II))
         DVX(IT+ISM(IC,II))=DVX(IT+ISM(JC,II))*ZSIGN
         MIXOLD=MIX(IT+ISM(IC,II))
         MIXNEW=MIX(IT+ISM(JC,II))
         DO 36 KC=1,NCOUR
         IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW
36       CONTINUE
      ENDIF
40    CONTINUE
      IF((K0.EQ.1).AND.(NCODE(5).EQ.5)) THEN
         FRZ=0.5
         ALB(IS+ISM(7,II))=-ALB(IS+ISM(8,II))
         IFR(IS+ISM(7,II))=IFR(IS+ISM(8,II))
         DVX(IT+ISM(7,II))=-DVX(IT+ISM(8,II))
         MIXOLD=MIX(IT+ISM(7,II))
         MIXNEW=MIX(IT+ISM(8,II))
      ELSE IF((K0.EQ.LZ).AND.(NCODE(6).EQ.5)) THEN
         FRZ=0.5
         ALB(IS+ISM(8,II))=-ALB(IS+ISM(7,II))
         IFR(IS+ISM(8,II))=IFR(IS+ISM(7,II))
         DVX(IT+ISM(8,II))=-DVX(IT+ISM(7,II))
         MIXOLD=MIX(IT+ISM(8,II))
         MIXNEW=MIX(IT+ISM(7,II))
      ENDIF
      IF(FRZ.EQ.0.5) THEN
         DO 45 KC=1,NCOUR
         IF(MIX(IT+KC).EQ.MIXOLD) MIX(IT+KC)=MIXNEW
45       CONTINUE
      ENDIF
50    GG3(IBLK)=FRX*FRZ
      DO 60 I=1,NCOUR*NMBLK
60    IFR(I)=MIX(IFR(I))
*----
*  ELIMINATION OF THE BLOCKS OUTSIDE THE DOMAIN
*----
      JBLK=0
      DO 80 IBLK=1,NMBLK
      IKK=INUM(IBLK)
      IF(IKK.GT.0) THEN
         JBLK=JBLK+1
         INUM(JBLK)=IKK
         IORI(JBLK)=IORI(IBLK)
         GG3(JBLK)=GG3(IBLK)
         IS=NCOUR*(IBLK-1)
         JS=NCOUR*(JBLK-1)
         DO 70 IC=1,NCOUR
         IFR(JS+IC)=IFR(IS+IC)
70       ALB(JS+IC)=ALB(IS+IC)
      ENDIF
80    CONTINUE
      NMBLK=JBLK
*
      DO 90 IKK=1,NMERGE
90    POURCE(IKK)=0.0
      DO 110 IBLK=1,NMBLK
      IKK=INUM(IBLK)
110   POURCE(IKK)=POURCE(IKK)+GG3(IBLK)
*----
*  VALIDATION OF VECTOR IFR
*----
      DO 120 IBLK=1,NMBLK
      IS=NCOUR*(IBLK-1)
      DO 120 IC=1,NCOUR
      ISURF=IFR(IS+IC)
      IF(ISURF.EQ.0) THEN
         GO TO 570
      ENDIF
      JC=1+MOD(ISURF-1,NCOUR)
      JT=NCOUR*((ISURF-1)/NCOUR)
      IF(MIX(JT+JC).NE.ISURF) THEN
         GO TO 570
      ENDIF
120   CONTINUE
*----
*  VALIDATION OF THE GEOMETRICAL RECIPROCITY AND MODIFICATION OF ALBEDOS
*----
      DO 130 IBLK=1,NMBLK
      IKK=INUM(IBLK)
      IKG=IGEN(IKK)
      IS=NCOUR*(IBLK-1)
      IT=NCOUR*(IKK-1)
      DO 130 IC=1,NCOUR
      ALB(IS+IC)=ALB(IS+IC)*GG3(IBLK)/POURCE(IKK)
      IP=1+MOD(MIX(IT+IC)-1,NCOUR)
      FR1=XX(IKG)*ZZ(IKG)
      IF((IP.EQ.7).OR.(IP.EQ.8)) FR1=1.5*SQRT(3.0)*XX(IKG)*XX(IKG)
      JP=1+MOD(IFR(IS+IC)-1,NCOUR)
      JKG=IGEN(1+(IFR(IS+IC)-1)/NCOUR)
      FR2=XX(IKG)*ZZ(JKG)
      IF((JP.EQ.7).OR.(JP.EQ.8)) FR2=1.5*SQRT(3.0)*XX(IKG)*XX(IKG)
      DELTA=ABS(FR1-FR2)
      IF(ABS(FR1-FR2).GT.EPS) THEN
         WRITE (HSMG,680) DIRR(IP),IKG,DIRR(JP),JKG
         CALL XABORT(HSMG)
      ENDIF
130   CONTINUE
*----
*  COMPUTE VECTOR DVX
*----
      DO 200 IKK=1,NMERGE
      IKG=IGEN(IKK)
      IF(NCOUR.EQ.6) THEN
         DO 140 IC=1,NCOUR
140      DDD(IC)=1.0/6.0
      ELSE IF(NCOUR.EQ.8) THEN
         SURFA=1.5*SQRT(3.0)*XX(IKG)*XX(IKG)
         DO 150 IC=1,6
150      DDD(IC)=XX(IKG)*ZZ(IKG)/(2.0*SURFA+6.0*XX(IKG)*ZZ(IKG))
         DDD(7)=SURFA/(2.0*SURFA+6.0*XX(IKG)*ZZ(IKG))
         DDD(8)=DDD(7)
      ENDIF
      IT=NCOUR*(IKK-1)
      DO 200 IC=1,NCOUR
      IF(MULTC.EQ.1) THEN
*        ROTH APPROXIMATION.
         DVX(IT+IC)=DDD(IC)
         MIX(IT+IC)=IKK
      ELSE
         DELTA=0.0
         I1=MIX(IT+IC)
         DO 180 JC=1,NCOUR
         IF(MIX(IT+JC).EQ.I1) DELTA=DELTA+DDD(JC)
180      CONTINUE
         ZSIGN=SIGN(1.0,DVX(IT+IC))
         DVX(IT+IC)=ZSIGN*DDD(IC)/DELTA
      ENDIF
200   CONTINUE
      IJAS=NCOUR*NMBLK
      IJAR=NCOUR*NMERGE
*----
*  RECOMPUTE VECTOR IFR FOR ROTH APPROXIMATION
*----
      IF(MULTC.EQ.1) THEN
         DO 210 I=1,IJAS
210      IFR(I)=1+(IFR(I)-1)/NCOUR
      ENDIF
*----
*  REMOVE THE UNUSED SURFACE NUMBERS
*----
      DO 240 I=1,IJAS
240   JF2(I)=0
      IJAT=0
      DO 250 I=1,IJAR
      J=MIX(I)
      IF(J.GT.IJAS) THEN
        GO TO 570
      ENDIF
      IF(JF2(J).EQ.0) THEN
         IJAT=IJAT+1
         JF2(J)=IJAT
      ENDIF
250   CONTINUE
      DO 260 I=1,IJAR
260   MIX(I)=JF2(MIX(I))
      DO 270 I=1,IJAS
270   IFR(I)=JF2(IFR(I))
*----
*  INCLUDE THE DP-1 APPROXIMATION
*----
      IF((MULTC.EQ.4).AND.(NCOUR.EQ.6)) THEN
*        DP-1 APPROXIMATION IN 2-D.
         DO 330 I1=IJAR,1,-1
         ZSIGN=SIGN(1.0,DVX(I1))
         FR1=ABS(DVX(I1))
         JND=(MIX(I1)-1)*3
         DO 320 JCOUR=1,3
         JSURF=(I1-1)*3+JCOUR
         DVX(JSURF)=FR1
320      MIX(JSURF)=JND+JCOUR
330      DVX(JSURF)=ZSIGN*FR1
         DO 350 I1=IJAS,1,-1
         ZSIGN=SIGN(1.0,ALB(I1))
         FR1=ABS(ALB(I1))
         JND=(IFR(I1)-1)*3
         DO 340 JCOUR=1,3
         JSURF=(I1-1)*3+JCOUR
         ALB(JSURF)=FR1
340      IFR(JSURF)=JND+JCOUR
350      ALB(JSURF)=ZSIGN*FR1
         NCOUR=18
      ELSE IF((MULTC.EQ.4).AND.(NCOUR.EQ.8)) THEN
         CALL XABORT('NUMERH: INVALID OPTION.')
      ELSE
         DO 360 I=1,IJAS
360      ALB(I)=ABS(ALB(I))
         DO 370 I=1,IJAR
370      DVX(I)=ABS(DVX(I))
      ENDIF
      IJAS=NCOUR*NMBLK
      IJAR=NCOUR*NMERGE
*----
*  PRINT THE SURFACE NUMBERS AFTER MERGING
*----
      IF(IMPX.GT.2) THEN
         WRITE (6,620)
         MIN8=MIN(8,NCOUR)
         WRITE (6,650) ('---------------',I=1,MIN8)
         DO 410 IBLK=1,NMBLK
         IKK=INUM(IBLK)
         WRITE (6,630) IBLK,IKK,IGEN(IKK),POURCE(IKK)
         I1=IORI(IBLK)
         IF((MULTC.EQ.4).AND.(NCOUR.EQ.18)) THEN
            DO 380 I=1,18
            ISMZ(I)=3*ISM(1+(I-1)/3,I1)+MOD(I-1,3)-2
380         DIRZ(I)=DIRR(1+(I-1)/3)
         ELSE
            DO 400 I=1,NCOUR
            ISMZ(I)=ISM(I,I1)
400         DIRZ(I)=DIRR(I)
         ENDIF
         IT0=NCOUR*(IBLK-1)
         IT1=NCOUR*(IKK-1)
         WRITE (6,660) (DIRZ(I),I=1,MIN8)
         WRITE (6,635) (MIX(IT1+ISMZ(I)),IFR(IT0+ISMZ(I)),I=1,MIN8)
         WRITE (6,640) (ALB(IT0+ISMZ(I)),I=1,MIN8)
         WRITE (6,645) (DVX(IT1+ISMZ(I)),I=1,MIN8)
         IF(NCOUR.EQ.18) THEN
            WRITE (6,660) (DIRZ(I),I=9,16)
            WRITE (6,635) (MIX(IT1+ISMZ(I)),IFR(IT0+ISMZ(I)),I=9,16)
            WRITE (6,640) (ALB(IT0+ISMZ(I)),I=9,16)
            WRITE (6,645) (DVX(IT1+ISMZ(I)),I=9,16)
            WRITE (6,660) (DIRZ(I),I=17,18)
            WRITE (6,635) (MIX(IT1+ISMZ(I)),IFR(IT0+ISMZ(I)),I=17,18)
            WRITE (6,640) (ALB(IT0+ISMZ(I)),I=17,18)
            WRITE (6,645) (DVX(IT1+ISMZ(I)),I=17,18)
         ENDIF
         WRITE (6,650) ('---------------',I=1,MIN8)
410      CONTINUE
      ENDIF
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(GG3,JF2)
      RETURN
*
570   WRITE (6,620)
      WRITE (6,650) ('---------------',I=1,NCOUR)
      DO 580 IBLK=1,NMBLK
      IKK=INUM(IBLK)
      WRITE (6,630) IBLK,IKK,IGEN(IKK),POURCE(IKK)
      I1=IORI(IBLK)
      IT0=NCOUR*(IBLK-1)
      IT1=NCOUR*(IKK-1)
      WRITE (6,660) (DIRR(I),I=1,NCOUR)
      WRITE (6,635) (MIX(IT1+ISM(I,I1)),IFR(IT0+ISM(I,I1)),I=1,NCOUR)
      WRITE (6,640) (ALB(IT0+ISM(I,I1)),I=1,NCOUR)
      WRITE (6,645) (DVX(IT1+ISM(I,I1)),I=1,NCOUR)
      WRITE (6,650) ('---------------',I=1,NCOUR)
580   CONTINUE
      CALL XABORT('NUMERH: FAILURE OF THE SURFACE RENUMBERING ALGORITH'
     1 //'M.')
*
610   FORMAT(9H HEXAGON=,I5,5X,11HNEIGHBOURS=,6I5,5X,7HWEIGHT=,F7.4)
620   FORMAT (///31H SURFACE NUMBERS AFTER MERGING./)
630   FORMAT (7H BLOCK=,I5,5X,13HMERGED BLOCK=,I5,5X,12HGENERATING B,
     1 5HLOCK=,I5,5X,7HPOURCE=,1P,E12.4)
635   FORMAT (8H IN/OUT:,8(I5,2H /,I5,3H  I))
640   FORMAT (8H ALBEDO:,1P,8(E12.4,3H  I))
645   FORMAT (8H    DVX:,1P,8(E12.4,3H  I))
650   FORMAT (8H -------,8(A15))
660   FORMAT (/8H   SIDE:,8(A9,5X,1HI))
680   FORMAT (49HNUMERH: GEOMETRICAL RECIPROCITY CONDITION IS VIOL,
     1 10HATED (SIDE,A3,20H OF GENERATING BLOCK,I5,8H VS SIDE,A3,
     2 20H OF GENERATING BLOCK,I5,3H ).)
      END
