1 files changed, 77 insertions, 0 deletions
diff --git a/Dragon/src/EDIHMX.f b/Dragon/src/EDIHMX.f
new file mode 100644
index 0000000..4685b6c
--- /dev/null
+++ b/Dragon/src/EDIHMX.f
@@ -0,0 +1,77 @@
+*DECK EDIHMX
+      SUBROUTINE EDIHMX(IPTRK,NREGIO,NMERGE,IMERGE)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Find merge vector for merge by HMIX.
+*
+*Copyright:
+* Copyright (C) 2001 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): G. Marleau
+*
+*Parameters: input
+* IPTRK   calculation tracking data structure.
+* NREGIO  number of regions.
+*
+*Parameters: output
+* NMERGE  final number of merged regions.
+* IMERGE  merged region positions.
+*
+*-----------------------------------------------------------------------
+*
+      USE         GANLIB
+      IMPLICIT    NONE
+      INTEGER     IOUT,NSTATE
+      CHARACTER   NAMSBR*6
+      PARAMETER  (IOUT=6,NSTATE=40,NAMSBR='EDIHMX')
+*----
+*  ROUTINE PARAMETERS
+*----
+      TYPE(C_PTR) IPTRK
+      INTEGER     NREGIO
+      INTEGER     NMERGE
+      INTEGER     IMERGE(NREGIO)
+*----
+*  LOCAL PARAMETERS
+*----
+      INTEGER     IMRGLN,IMRGTY,IREG
+      INTEGER     ISTATE(NSTATE)
+*----
+*  IMERGE is HOMMATCOD or MATCOD
+*----
+      CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE)
+      CALL LCMLEN(IPTRK,'HOMMATCOD   ',IMRGLN,IMRGTY)
+      IF(IMRGLN .EQ. 0) THEN
+        WRITE(IOUT,8000) NAMSBR
+        CALL LCMGET(IPTRK,'MATCOD      ',IMERGE)
+      ELSE
+        CALL LCMGET(IPTRK,'HOMMATCOD   ',IMERGE)
+      ENDIF
+*----
+*  Check for double heterogeneity
+*----
+      IF(ISTATE(40).EQ.1) THEN
+        CALL EDIBHX (NREGIO,IPTRK,IMRGLN,IMERGE)
+      ENDIF
+      IF(IMRGLN.NE.NREGIO) CALL XABORT('EDIHMX: bad nb of regions')
+*----
+*  Compute number of merged regions
+*----
+      NMERGE=0
+      DO IREG=1,NREGIO
+        NMERGE=MAX(NMERGE,IMERGE(IREG))
+      ENDDO
+      RETURN
+*----
+*  WARNING FORMAT
+*----
+ 8000 FORMAT('***** Warning in routine - ',A6,' - *****'/
+     >'No HMIX data in GEO: for NXT tracking file'/
+     >'Homogenize using MIX instead of HMIX')
+      END