summaryrefslogtreecommitdiff
path: root/Dragon/src/EDIMRG.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/EDIMRG.f')
-rw-r--r--Dragon/src/EDIMRG.f235
1 files changed, 235 insertions, 0 deletions
diff --git a/Dragon/src/EDIMRG.f b/Dragon/src/EDIMRG.f
new file mode 100644
index 0000000..6929109
--- /dev/null
+++ b/Dragon/src/EDIMRG.f
@@ -0,0 +1,235 @@
+*DECK EDIMRG
+ SUBROUTINE EDIMRG(IPTRK ,IPMRG ,IPRINT,GEONAM,ITM ,NREGIO,
+ > NMERGE,IMERGE)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Find merge vector by mixtures.
+*
+*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 pointer to the TRACKING data structure.
+* IPMRG merge geometry (ITM=-1) or
+* tracking (ITM=1) data structure.
+* IPRINT print level.
+* GEONAM geometry name.
+* ITM type of merge:
+* =-1 merge from second geometry;
+* = 0 merge from calculation tracking;
+* = 1 merge from second tracking.
+* NREGIO number of regions.
+*
+*Parameters: output
+* NMERGE final number of merged regions.
+* IMERGE merged region index.
+*
+*-----------------------------------------------------------------------
+*
+*
+*--------------------------- EDIMRG ---------------------------------
+*
+* 1- PROGRAMME STATISTICS:
+* NAME : EDIMRG
+* USE : FIND MERGE VECTOR BY MIXTURES IN IPMRG
+* WITH IPTRK
+* MODIFIED : 2001/10/30 (G.M)
+* AUTHOR : G.MARLEAU
+*
+* 2- ROUTINE PARAMETERS:
+* IPTRK : CALCULATION TRACKING DATA STRUCTURE
+* ***> INTEGER IPTRKI
+* IPMRG : MERGE GEOMETRY (ITM=-1) OR
+* TRACKING (ITM=1) DATA STRUCTURE I
+* ***> INTEGER IPMRG
+* IPRINT : PRINT LEVEL
+* ***> INTEGER IPRINT
+* GEONAM : GEOMETRY NAME
+* ***> CHARACTER*12 GEONAM
+* ITM : TYPE OF MERGE I
+* ITM = -1 -> FROM SECOND GEOMETRY
+* ITM = 0 -> FROM CALCULATION TRACKING
+* ITM = 1 -> FROM SECOND TRACKING
+* ***> INTEGER ITM
+* NREGIO : NUMBER OF REGIONS
+* ***> INTEGER NREGIO
+* NMERGE : FINAL NUMBER OF MERGED REGIONS
+* ***> INTEGER NMERGE
+* IMERGE : MERGED REGIONS POSITION
+* ***> INTEGER IMERGE(NREGIO)
+*
+*--------------------------- EDIMRG --------------------------------
+*
+ USE GANLIB
+ IMPLICIT NONE
+ INTEGER IOUT,NSTATE
+ CHARACTER NAMSBR*6
+ PARAMETER (IOUT=6,NSTATE=40,NAMSBR='EDIMRG')
+*----
+* ROUTINE PARAMETERS
+*----
+ TYPE(C_PTR) IPTRK
+ TYPE(C_PTR) IPMRG
+ INTEGER IPRINT
+ CHARACTER GEONAM*12
+ INTEGER ITM
+ INTEGER NREGIO
+ INTEGER NMERGE
+ INTEGER IMERGE(NREGIO)
+*----
+* LOCAL PARAMETERS
+*----
+ INTEGER ISTATE(NSTATE)
+ TYPE(C_PTR) IPTRK2
+ INTEGER IMODT2,IMEDT2,ICLST2,IPRIN2
+ INTEGER ITYPEG,ITGEO
+ CHARACTER NAMTR2*12
+ CHARACTER HSIGN*12
+ 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
+*----
+* ALLOCATABLE ARRAYS
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: KEYMRG,MATALB,MATMRG,MERT
+ REAL, ALLOCATABLE, DIMENSION(:) :: VOLSUR,VOLMRG
+*----
+* LOCAL NAME OF TEMPORARY TRACKING FILE
+* WHEN IPGEO IS PROVIDED
+*----
+ 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 '
+ CALL LCMPTC(IPTRK2,'SIGNATURE',12,HSIGN)
+ HSIGN='EXCELL '
+ CALL LCMPTC(IPTRK2,'TRACK-TYPE',12,HSIGN)
+*----
+* ANALYZE GEOMETRY
+*----
+ 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
+*----
+* CLUSTER GEOMETRY
+*----
+ ISYMM=1
+*c CALL AXGXCW(IPMRG ,IPTRK2,IPRINT,GEONAM,ISYMM )
+ CALL XABORT('EDIMRG: NOT IMPLEMENTED(1):'//GEONAM)
+ ITROP=3
+ ELSE IF(ITGEO .EQ. 2 ) THEN
+*----
+* HEXAGONAL 2D GEOMETRIES
+*----
+* CALL AXGXHX(IPMRG ,IPTRK2,IPRINT,GEONAM)
+ ITROP=2
+ ELSE IF(ITGEO .EQ. 3 ) THEN
+*----
+* CARTESIAN 2D/3D ASSEMBLIES
+* CALL XELPRP TO GET GEOMETRY DIMENSIONING INFORMATION
+*----
+*c 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)
+ 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))
+ EXTKOP(:NSTATE)=0.0
+ CALL LCMPUT(IPTRK2,'EXCELTRACKOP',NSTATE,2,EXTKOP)
+ 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)
+*----
+* IF IPRINT >= 10
+* EXPORT TEMPORARY TRACKING FILE
+*----
+ 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
+*----
+* DESTROY TEMPORARY TRACKING FILE
+* WHEN IPGEO IS PROVIDED
+*----
+ ALLOCATE(MERT(NREGIO+1))
+ MERT(:NREGIO+1)=1
+*C 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
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 11:33:54 +0000