*DECK EDIMRG
      SUBROUTINE EDIMRG(IPTRK ,IPMRG ,IPRINT,GEONAM,ITM   ,NREGIO,
     >                  NMERGE,IMERGE)
C
C---------------------------  EDIMRG  ---------------------------------
C
C  1- PROGRAMME STATISTICS:
C      NAME     : EDIMRG
C      USE      : FIND MERGE VECTOR BY MIXTURES IN IPMRG
C                 WITH IPTRK
C      MODIFIED : 2001/10/30 (G.M)
C      AUTHOR   : G.MARLEAU
C
C  2- ROUTINE PARAMETERS: 
C      IPTRK    : CALCULATION TRACKING DATA STRUCTURE    
C                 ***> INTEGER IPTRKI
C      IPMRG    : MERGE GEOMETRY (ITM=-1) OR 
C                 TRACKING (ITM=1) DATA STRUCTURE        I
C                 ***> INTEGER IPMRG
C      IPRINT   : PRINT LEVEL                     
C                 ***> INTEGER IPRINT
C     GEONAM : GEOMETRY NAME
C              ***> CHARACTER*12 GEONAM
C      ITM      : TYPE OF MERGE                          I
C                 ITM = -1 -> FROM SECOND GEOMETRY
C                 ITM = 0  -> FROM CALCULATION TRACKING
C                 ITM = 1  -> FROM SECOND TRACKING
C                 ***> INTEGER ITM
C      NREGIO   : NUMBER OF REGIONS                     
C                 ***> INTEGER NREGIO
C      NMERGE   : FINAL NUMBER OF MERGED REGIONS         
C                 ***> INTEGER NMERGE
C      IMERGE   : MERGED REGIONS POSITION                
C                 ***> INTEGER IMERGE(NREGIO)
C
C---------------------------   EDIMRG  --------------------------------
C
      USE         GANLIB
      IMPLICIT    NONE
      INTEGER     IOUT,NSTATE
      CHARACTER   NAMSBR*6
      PARAMETER  (IOUT=6,NSTATE=40,NAMSBR='EDIMRG')
C----
C  ROUTINE PARAMETERS
C----
      TYPE(C_PTR) IPTRK
      TYPE(C_PTR) IPMRG
      INTEGER     IPRINT
      CHARACTER   GEONAM*12
      INTEGER     ITM
      INTEGER     NREGIO
      INTEGER     NMERGE
      INTEGER     IMERGE(NREGIO)
C----
C  LOCAL PARAMETERS
C----
      INTEGER     ISTATE(NSTATE)
      TYPE(C_PTR) IPTRK2
      INTEGER     IMODT2,IMEDT2,ICLST2,IPRIN2
      INTEGER     ITYPEG,ITGEO
      CHARACTER   NAMTR2*12
      CHARACTER   HSIGN*12
      INTEGER     KCHAR(18),ITCR
      INTEGER     NV,NS,NSOUT,NREG,NUNK,ICODE(6)
      REAL        EXTKOP(NSTATE)
      INTEGER     ITROP,MAXMIX,IREG,ISYMM
      INTEGER     IUEXP,KDROPN,KDRCLS,IRC
      INTEGER     ITYPM
      LOGICAL     LASS,LDRASS
C----
C  ALLOCATABLE ARRAYS
C----
      INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYMRG,MATALB,MATMRG,MERT
      REAL, ALLOCATABLE, DIMENSION(:) :: VOLSUR,VOLMRG
C----
C  LOCAL NAME OF TEMPORARY TRACKING FILE
C  WHEN IPGEO IS PROVIDED
C----
      NAMTR2='EDIMRGIPTRK2'
      IMODT2=0
      IMEDT2=1
      IPRIN2=0
      ICLST2=2
      ITYPM=1
      ITROP=0
      IF(ITM .EQ. -1) THEN
        LASS=LDRASS(IPMRG,IPRINT)
        CALL LCMOP(IPTRK2,NAMTR2,IMODT2,IMEDT2,IPRIN2)
        HSIGN='L_TRACK     '
        READ(HSIGN,'(3A4)') (KCHAR(ITCR),ITCR=1,3)
        CALL LCMPUT(IPTRK2,'SIGNATURE   ',3,3,KCHAR)
        HSIGN='EXCELL      '
        READ(HSIGN,'(3A4)') (KCHAR(ITCR),ITCR=1,3)
        CALL LCMPUT(IPTRK2,'TRACK-TYPE  ',3,3,KCHAR)
C----
C  ANALYZE GEOMETRY
C----
        CALL XDISET(ISTATE,NSTATE,0)
        CALL LCMGET(IPMRG,'STATE-VECTOR',ISTATE)
        ITYPEG= ISTATE(1)
        IF(ITYPEG .EQ. 3 .OR. ITYPEG .EQ. 6 ) THEN
          ITGEO= 1
        ELSE IF(ITYPEG .EQ.  8 .OR. ITYPEG .EQ.  9 .OR.
     >          ITYPEG .EQ. 24 .OR. ITYPEG .EQ. 25      ) THEN
          ITGEO= 2
        ELSE IF(ITYPEG .EQ.  5 .OR. ITYPEG .EQ.  7 .OR.
     >          ITYPEG .EQ. 20 .OR. ITYPEG .EQ. 21 .OR.
     >          ITYPEG .EQ. 22 .OR. ITYPEG .EQ. 23      ) THEN
          ITGEO= 3
        ELSE
          ITGEO= 0
        ENDIF
        IF(ISTATE(13) .GE. 1) THEN
C----
C  CLUSTER GEOMETRY
C----
          ISYMM=1
cc          CALL AXGXCW(IPMRG ,IPTRK2,IPRINT,GEONAM,ISYMM )
          CALL XABORT('EDIMRG: NOT IMPLEMENTED(1):'//GEONAM)
          ITROP=3
        ELSE IF(ITGEO .EQ. 2 ) THEN
C----
C  HEXAGONAL 2D GEOMETRIES
C----
C          CALL AXGXHX(IPMRG ,IPTRK2,IPRINT,GEONAM)
          ITROP=2
        ELSE IF(ITGEO .EQ. 3 ) THEN
C----
C  CARTESIAN 2D/3D ASSEMBLIES
C  CALL XELPRP TO GET GEOMETRY DIMENSIONING INFORMATION
C----
cc          CALL AXGXEL(IPMRG ,IPTRK2,IPRINT,GEONAM)
          CALL XABORT('EDIMRG: NOT IMPLEMENTED(2):'//GEONAM)
          ITROP=1
        ELSE
          CALL XABORT(NAMSBR//': INVALID TYPE OF GEOMETRY')
        ENDIF
        CALL LCMGET(IPTRK2,'ICODE       ',ICODE)
        CALL LCMSIX(IPTRK2,'EXCELL      ',1)
        CALL XDISET(ISTATE,NSTATE,0)
        CALL LCMGET(IPTRK2,'STATE-VECTOR',ISTATE)
        NV=ISTATE(3)
        NS=ISTATE(2)
        NUNK=NV+NS+1
        ALLOCATE(KEYMRG(NUNK),MATALB(NUNK),VOLSUR(NUNK))
        CALL LCMGET(IPTRK2,'KEYMRG      ',KEYMRG)
        CALL LCMGET(IPTRK2,'MATALB      ',MATALB)
        CALL LCMGET(IPTRK2,'VOLSUR      ',VOLSUR)
        CALL LCMSIX(IPTRK2,'EXCELL      ',2)
        ALLOCATE(MATMRG(NUNK),VOLMRG(NUNK))
        CALL XELCMP(NS    ,NV    ,VOLSUR,MATALB,KEYMRG,NSOUT ,
     >              NREG  ,VOLMRG,MATMRG,ITGEO ,ICODE )
        MAXMIX=0
        DO 100 IREG=1,NREG
          KEYMRG(IREG+NSOUT+1)= IREG
          MAXMIX=MAX(MAXMIX,MATMRG(IREG+NSOUT+1))
 100    CONTINUE
        CALL LCMPUT(IPTRK2,'MATCOD',NREG,1,MATMRG(NSOUT+2))
        CALL LCMPUT(IPTRK2,'VOLUME',NREG,2,VOLMRG(NSOUT+2))
        CALL LCMPUT(IPTRK2,'KEYFLX',NREG,1,KEYMRG(NSOUT+2))
        CALL XDRSET(EXTKOP,NSTATE,0.0)
        CALL LCMPUT(IPTRK2,'EXCELTRACKOP',NSTATE,2,EXTKOP)
        CALL XDISET(ISTATE,NSTATE,0)
        ISTATE(1)=NREG
        ISTATE(2)=NREG
        ISTATE(4)=MAXMIX
        ISTATE(5)=NSOUT
        ISTATE(7)=ITROP
        ISTATE(8)=-1
        CALL LCMPUT(IPTRK2,'STATE-VECTOR',NSTATE,1,ISTATE)
        DEALLOCATE(VOLSUR,MATALB,KEYMRG)
        DEALLOCATE(VOLMRG,MATMRG)
        DEALLOCATE(VOLSUR,MATALB,KEYMRG)
C----
C  IF IPRINT >= 10
C  EXPORT TEMPORARY TRACKING FILE
C----
        IF(IPRINT .GE. 10) THEN
          IUEXP=KDROPN('EDIMRGEXP',0,3,0)
          CALL LCMEXP(IPTRK2,IPRINT,IUEXP,2,1)
          IRC=KDRCLS(IUEXP,1)
        ENDIF
      ELSE
        IPTRK2=IPMRG
      ENDIF
C----
C  DESTROY TEMPORARY TRACKING FILE
C  WHEN IPGEO IS PROVIDED
C----
      ALLOCATE(MERT(NREGIO+1))
      CALL XDISET(MERT,NREGIO+1,1)
CC      CALL MRGTRK(IPTRK ,IPTRK2,IPRINT,ITYPM ,NREGIO, MERT)
        CALL LCMLIB(IPTRK)
      CALL XABORT('EDIMRG: NOT IMPLEMENTED(3)')
      NMERGE=0
      DO 110 IREG=1,NREGIO
        IMERGE(IREG)=MERT(IREG+1)
        NMERGE=MAX(NMERGE,IMERGE(IREG))
 110  CONTINUE
      DEALLOCATE(MERT)
      IF(ITM .EQ. -1) THEN
        CALL LCMCL(IPTRK2,ICLST2)
      ENDIF
      RETURN
      END
