summaryrefslogtreecommitdiff
path: root/Dragon/src/MRG.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/MRG.f')
-rw-r--r--Dragon/src/MRG.f380
1 files changed, 380 insertions, 0 deletions
diff --git a/Dragon/src/MRG.f b/Dragon/src/MRG.f
new file mode 100644
index 0000000..6826075
--- /dev/null
+++ b/Dragon/src/MRG.f
@@ -0,0 +1,380 @@
+*DECK MRG
+ SUBROUTINE MRG(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
+*
+*----------
+*
+*Purpose:
+* Merge EXCELT or NXT geometry.
+*
+*Copyright:
+* Copyright (C) 1997 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/output
+* NENTRY number of LCM objects or files used by the operator.
+* HENTRY name of each LCM object or file:
+* HENTRY(1) creation type(L_MC);
+* HENTRY(2) read-only or modification type(L_TRACK);
+* HENTRY(3) read-only type(L_LIBRARY) or type(L_MACROLIB).
+* IENTRY type of each LCM object or file:
+* =1 LCM memory object; =2 XSM file; =3 sequential binary file;
+* =4 sequential ascii file.
+* JENTRY access of each LCM object or file:
+* =0 the LCM object or file is created;
+* =1 the LCM object or file is open for modifications;
+* =2 the LCM object or file is open in read-only mode.
+* KENTRY LCM object address or file unit number.
+*
+*Comments:
+* LINKED LIST / XSM FILE:
+* HENTRY(1) : CREATION OR UPDATE MODE LINKED LIST TYPE(L_TRACK)
+* (CREATION only for EXCELT: type tracking).
+* HENTRY(2) : CREATION MODE SEQUENTIAL BINARY TRACKING FILE
+* (optionnal for NXT: type tracking).
+* HENTRY(3) : READ-ONLY LINKED LIST TYPE(L_TRACK)
+* (optionnal for NXT: type tracking).
+* HENTRY(4) : READ-ONLY SEQUENTIAL BINARY TRACKING FILE
+* (optionnal for NXT: type tracking).
+*
+*----------
+*
+ USE GANLIB
+ IMPLICIT NONE
+ INTEGER IOUT,NSTATE,NTC,NALB
+ CHARACTER NAMSBR*6
+ PARAMETER (IOUT=6,NSTATE=40,NTC=18,NALB=6,
+ > NAMSBR='MRG ')
+*----
+* ROUTINE PARAMETERS
+*----
+ INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY)
+* INTEGER KENTRY(NENTRY)
+ TYPE(C_PTR) KENTRY(NENTRY)
+ CHARACTER HENTRY(NENTRY)*12
+*----
+* Function for inport/export DDS
+*----
+ INTEGER KDROPN,KDRCLS,IRC,IFILE
+*----
+* LOCAL VARIABLES
+*----
+ INTEGER IDTRKO,IDTRKN,IDTRKE,IDSTRO,IDSTRN,IEN,
+ > IFTRKO,IFTRKN,IFTRKE
+* INTEGER IPTRKN,IPTRKO
+ TYPE(C_PTR) IPTRKO,IPTRKN
+ INTEGER ISTATE(NSTATE),ISTATG(NSTATE)
+ INTEGER ITC
+ CHARACTER HSIGN*12
+ INTEGER NREGO,NUNO,NUNN,NSURO,NUNF,ITROP,
+ > NSOUTO,NVOUTO,NSOUTN,NVOUTN,ILCMLN,ILCMTY,
+ > NETSUR,NETVOL,NETNUO,NETNUN,NELT,MAXMN
+ INTEGER IPRINT,IUPD(4),NDIM,INDBC
+ REAL ALBEDN(NALB)
+*----
+* Tracking file variables
+*----
+ INTEGER IFMT,NCOMNT,NBTRK,NSCRP(9),NALBG,NANGL,MXSEG,
+ > MXSUB,NUNKNO,NUNKNN,IOPTT,MAXMIX
+ CHARACTER CTRK*4,COMENT*80
+*----
+* Allocatable arrays
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: IMERGE,MIXN,MATO,MATRTO,
+ > MATN,KEYN,MATRTN,NEXMAT,NEXKEY,NEXMAN,NEXKEN
+ REAL, ALLOCATABLE, DIMENSION(:) :: VOLO,VOLN
+*----
+* PARAMETER VALIDATION
+*----
+ IF(NENTRY .LT. 1 .OR. NENTRY .GT. 4) CALL XABORT(NAMSBR//
+ > ': From 1 to 4 data structures required')
+*----
+* Find and validate structure types
+*----
+ IDTRKO=0
+ IDTRKN=0
+ IDTRKE=0
+ IDSTRO=0
+ IDSTRN=0
+ IOPTT=0
+ DO IEN=1,NENTRY
+ IF(IENTRY(IEN) .EQ. 1 .OR. IENTRY(IEN) .EQ. 2) THEN
+ IF(JENTRY(IEN) .EQ. 0) THEN
+ IDSTRN=IEN
+ ELSE IF(JENTRY(IEN) .EQ. 1) THEN
+ IDSTRN=IEN
+ IDSTRO=IEN
+ ELSE
+ IDSTRO=IEN
+ ENDIF
+ ELSE IF(IENTRY(IEN) .EQ. 3) THEN
+ IF(JENTRY(IEN) .EQ. 0) THEN
+ IF(IDTRKN .EQ. 0) THEN
+ IDTRKN=IEN
+ ELSE
+ IDTRKE=IEN
+ ENDIF
+ ELSE IF(JENTRY(IEN) .EQ. 2) THEN
+ IDTRKO=IEN
+ ENDIF
+ ELSE
+ CALL XABORT(NAMSBR//': One data structure has invalid type')
+ ENDIF
+ ENDDO
+ IF(IDSTRO .EQ. 0) CALL XABORT(NAMSBR//
+ >': Reference tracking data structure missing')
+ IF(IDSTRN .NE. IDSTRO) THEN
+*----
+* Make a full copy of the old data structure to the new data structure
+* we will update later
+*----
+ IPTRKO=KENTRY(IDSTRO)
+ IPTRKN=IPTRKO
+ IF(IDSTRN .NE. 0) THEN
+ IPTRKN=KENTRY(IDSTRN)
+ IFILE=KDROPN('DUMMYSQ',0,2,0,0)
+ IF(IFILE.LE.0) CALL XABORT(NAMSBR//': KDROPN FAILURE.')
+ CALL LCMEXP(IPTRKO,0,IFILE,1,1)
+ REWIND(IFILE)
+ CALL LCMEXP(IPTRKN,0,IFILE,1,2)
+ IRC=KDRCLS(IFILE,2)
+ ENDIF
+ ELSE
+ IPTRKN=KENTRY(IDSTRN)
+ ENDIF
+*----
+* Test contents of the data structure to update
+* Either old data structure or new data structure that now contains
+* a copy of the old data structure
+*----
+ CALL LCMGTC(IPTRKN,'SIGNATURE ',12,HSIGN)
+ IF(HSIGN .NE. 'L_TRACK') CALL XABORT(NAMSBR//
+ > ': SIGNATURE OF '//HENTRY(3)//' IS '//HSIGN//
+ > '. L_TRACK EXPECTED.')
+ CALL LCMGTC(IPTRKN,'TRACK-TYPE ',12,HSIGN)
+ IF(HSIGN .NE. 'EXCELL') CALL XABORT(NAMSBR//
+ > ': ILLEGAL TRACKING FORMAT')
+ ISTATE(:NSTATE)=0
+ CALL LCMGET(IPTRKN,'STATE-VECTOR',ISTATE)
+ NREGO=ISTATE(1)
+ NUNO=ISTATE(2)
+ NUNF=NUNO/NREGO
+ MAXMIX=ISTATE(4)
+ NSURO=ISTATE(5)
+ ITROP=ISTATE(7)
+*----
+* Test if NXT: or EXCELT: tracking
+* For EXCELT: -> tracking files are required
+* For NXT: -> tracking files are optional
+*----
+ IF(ITROP .GE. 1 .AND. ITROP .LE. 3) THEN
+ IF(IDTRKO .EQ. 0 .OR. IDTRKN .EQ. 0) CALL XABORT(NAMSBR//
+ > ': Tracking files required for EXCELT: tracking')
+ IOPTT=1
+ ELSE IF(ITROP .EQ. 4) THEN
+ IF(IDTRKO .EQ. 0 .AND. IDTRKN .EQ. 0) THEN
+ IOPTT=2
+ ELSE IF(IDTRKO .GT. 0 .AND. IDTRKN .GT. 0) THEN
+ IOPTT=3
+ IF(IDTRKE .GT. 0) IOPTT=4
+ ELSE
+ CALL XABORT(NAMSBR//
+ > ': Either 0, 2 or 3 tracking files required for NXT: tracking')
+ ENDIF
+ ELSE
+ CALL XABORT(NAMSBR//
+ > ': Invalid tracking options on tracking data structure')
+ ENDIF
+ NVOUTO=NREGO
+ NSOUTO=NSURO
+*----
+* READ MERGE INFORMATION
+*----
+ ALLOCATE(IMERGE(-NSOUTO:NVOUTO),MIXN(NVOUTO))
+ CALL MRGGET(IPRINT,NSOUTO,NVOUTO,NSOUTN,NVOUTN,
+ > IUPD,IMERGE,MIXN,ALBEDN)
+ IF(IPRINT .GE. 1) THEN
+ WRITE(IOUT,6000) NAMSBR
+ ENDIF
+ IF(IOPTT .NE. 4) THEN
+ NUNN=NUNF*NVOUTN
+ ISTATE(1)=NVOUTN
+ ISTATE(2)=NUNN
+ ISTATE(5)=NSOUTN
+*----
+* Read global records to merge
+*----
+ ALLOCATE(MATN(NVOUTN),VOLN(NVOUTN),MATRTN(NSOUTN),KEYN(NREGO))
+ ALLOCATE(MATO(NVOUTO),VOLO(NVOUTO),MATRTO(NSOUTO))
+ CALL LCMGET(IPTRKN,'MATCOD ',MATO)
+ CALL LCMGET(IPTRKN,'VOLUME ',VOLO)
+ CALL LCMLEN(IPTRKN,'BC-REFL+TRAN',ILCMLN,ILCMTY)
+ IF(ILCMLN .EQ. NSOUTO) THEN
+ INDBC=1
+ CALL LCMGET(IPTRKN,'BC-REFL+TRAN',MATRTO)
+ ELSE
+ INDBC=0
+ MATRTO(:NSOUTO)=0
+ ENDIF
+ NETNUN=NSOUTN+NVOUTN+1
+ IF(ITROP .EQ. 4) THEN
+*----
+* Process NXT: Records
+*----
+ CALL LCMSIX(IPTRKN,'NXTRecords ',1)
+ ISTATG(:NSTATE)=0
+ CALL LCMGET(IPTRKN,'G00000001DIM',ISTATG)
+ NETSUR=ISTATG(22)
+ NETVOL=ISTATG(23)
+ NELT=NETSUR+NETVOL+1
+ ALLOCATE(NEXMAT(NELT),NEXKEY(NELT))
+ CALL LCMGET(IPTRKN,'MATALB ',NEXMAT)
+ CALL LCMGET(IPTRKN,'KEYMRG ',NEXKEY)
+ CALL MRGVON(IUPD ,NSOUTO,NVOUTO,NSOUTN,NVOUTN,
+ > NETSUR,NETVOL,NUNN ,MAXMN ,
+ > IMERGE,MATO ,VOLO ,MATRTO,
+ > MATN ,VOLN ,KEYN ,MATRTN,
+ > NEXMAT,NEXKEY)
+*----
+* Save NXT: specific records
+*----
+ CALL LCMPUT(IPTRKN,'MATALB ',NELT,1,NEXMAT)
+ CALL LCMPUT(IPTRKN,'KEYMRG ',NELT,1,NEXKEY)
+ CALL LCMSIX(IPTRKN,'NXTRecords ',2)
+ DEALLOCATE(NEXKEY,NEXMAT)
+ ELSE
+*----
+* Process EXCELT: Records
+*----
+ CALL LCMSIX(IPTRKN,'EXCELL ',1)
+ ISTATG(:NSTATE)=0
+ CALL LCMGET(IPTRKN,'STATE-VECTOR',ISTATG)
+ NETSUR=ISTATG(2)
+ NETVOL=ISTATG(3)
+ NETNUO=ISTATG(6)
+ ALLOCATE(NEXMAT(-NETSUR:NETVOL),NEXKEY(-NETSUR:NETVOL))
+ ALLOCATE(NEXMAN(-NSOUTN:NVOUTN),NEXKEN(-NSOUTN:NVOUTN))
+ CALL LCMGET(IPTRKO,'MATALB ',NEXMAT)
+ CALL LCMGET(IPTRKO,'KEYMRG ',NEXKEY)
+ CALL MRGVOL(IUPD ,NSOUTO,NVOUTO,NSOUTN,NVOUTN,NREGO ,
+ > IMERGE,MIXN ,MATO ,VOLO ,MATN ,VOLN ,
+ > KEYN ,MATRTO,MATRTN,MAXMN ,NETVOL,NETSUR,
+ > NEXMAT,NEXKEY,NEXMAN,NEXKEN)
+*----
+* Save EXCELT: specific records
+*----
+ CALL LCMPUT(IPTRKN,'MATALB ',NETNUN,1,NEXMAN)
+ CALL LCMPUT(IPTRKN,'KEYMRG ',NETNUN,1,NEXKEN)
+ CALL LCMPUT(IPTRKN,'STATE-VECTOR',NSTATE,1,ISTATG)
+ CALL LCMSIX(IPTRKN,'EXCELL ',2)
+ DEALLOCATE(NEXKEN,NEXMAN)
+ DEALLOCATE(NEXKEY,NEXMAT)
+ ENDIF
+ ISTATE(1)=NVOUTN
+ ISTATE(2)=NUNN
+ ISTATE(4)=MAXMN
+ ISTATE(5)=NSOUTN
+*----
+* Save global tracking records
+*----
+ CALL LCMPUT(IPTRKN,'STATE-VECTOR',NSTATE,1,ISTATE)
+ IF(IUPD(4). GT. 0 ) THEN
+ CALL LCMPUT(IPTRKN,'ALBEDO ',NALB,2,ALBEDN)
+ ENDIF
+ CALL LCMPUT(IPTRKN,'MATCOD ',NVOUTN,1,MATN)
+ CALL LCMPUT(IPTRKN,'VOLUME ',NVOUTN,2,VOLN)
+ IF(IUPD(1) .GT. 0) THEN
+ CALL LCMPUT(IPTRKN,'KEYFLX ',NVOUTN,1,KEYN)
+ ENDIF
+ CALL LCMPUT(IPTRKN,'BC-REFL+TRAN',NSOUTN,1,MATRTN)
+ DEALLOCATE(MATRTO,VOLO,MATO)
+ DEALLOCATE(MATN,VOLN,KEYN,MATRTN)
+*----
+* Processing of tracking data structure finished
+* Now process tracking file if required
+*----
+ IF(IDTRKN .GT. 0) THEN
+ IFTRKN=FILUNIT(KENTRY(IDTRKN))
+ IFTRKO=FILUNIT(KENTRY(IDTRKO))
+ READ (IFTRKO) CTRK,NCOMNT,NBTRK,IFMT
+ WRITE(IFTRKN) CTRK,NCOMNT,NBTRK,IFMT
+ DO ITC= 1, NCOMNT
+ READ (IFTRKO) COMENT
+ WRITE(IFTRKN) COMENT
+ ENDDO
+ READ (IFTRKO) (NSCRP(ITC),ITC=1,9)
+ NDIM =NSCRP(1)
+ IF(NVOUTO .NE. NSCRP(3)) CALL XABORT(NAMSBR//
+ > ': Number of regions on tracking file inconsistent with '//
+ > 'that on tracking data structure')
+ IF(NSOUTO .NE. NSCRP(4)) CALL XABORT(NAMSBR//
+ > ': Number of surfaces on tracking file inconsistent with '//
+ > 'that on tracking data structure')
+ NALBG= NSCRP(5)
+ NANGL= NSCRP(7)
+ MXSUB= NSCRP(8)
+ MXSEG= NSCRP(9)
+ NSCRP(3)=NVOUTN
+ NSCRP(4)=NSOUTN
+ WRITE(IFTRKN) (NSCRP(ITC),ITC=1,9)
+ NUNKNO=NSOUTO+NVOUTO
+ CALL MRGVST(IFTRKO,IFTRKN,IPRINT,IUPD ,NDIM ,NALBG,NANGL,
+ > NSOUTO,NVOUTO,NSOUTN,NVOUTN,IMERGE,MIXN )
+ NUNKNN=NSOUTN+NVOUTN
+*----
+* TRACKING LINE
+*----
+ CALL MRGLIN(IPRINT,IFTRKO,NSOUTO,NVOUTO,IFTRKN,
+ > IMERGE,NDIM,IFMT,MXSUB,MXSEG)
+ ENDIF
+ ELSE
+*----
+* SPLIT TRACKING FILE
+*---
+ IF(IUPD(1) .GE. 0) CALL XABORT(NAMSBR//
+ > ': No region specified for EXTR')
+ IFTRKN=FILUNIT(KENTRY(IDTRKN))
+ IFTRKO=FILUNIT(KENTRY(IDTRKO))
+ IFTRKE=FILUNIT(KENTRY(IDTRKE))
+ READ (IFTRKO) CTRK,NCOMNT,NBTRK
+ WRITE(IFTRKN) CTRK,NCOMNT,NBTRK
+ WRITE(IFTRKE) CTRK,NCOMNT,NBTRK
+ DO ITC= 1, NCOMNT
+ READ (IFTRKO) COMENT
+ IF(COMENT .EQ. 'OPTION : Extended ') IFMT=1
+ WRITE(IFTRKN) COMENT
+ WRITE(IFTRKE) COMENT
+ ENDDO
+ READ (IFTRKO) (NSCRP(ITC),ITC=1,8)
+ NDIM =NSCRP(1)
+ IF(NVOUTO .NE. NSCRP(3)) CALL XABORT(NAMSBR//
+ > ': Number of regions on tracking file inconsistent with '//
+ > 'that on tracking data structure')
+ IF(NSOUTO .NE. NSCRP(4)) CALL XABORT(NAMSBR//
+ > ': Number of surfaces on tracking file inconsistent with '//
+ > 'that on tracking data structure')
+ NALBG= NSCRP(5)
+ NANGL= NSCRP(7)
+ MXSEG= NSCRP(8)
+ WRITE(IFTRKN) (NSCRP(ITC),ITC=1,8)
+ WRITE(IFTRKE) (NSCRP(ITC),ITC=1,8)
+ NUNKNO=NSOUTO+NVOUTO
+ CALL MRGXTC(IFTRKO,IFTRKN,IFTRKE,IPRINT,IUPD ,NDIM,
+ > NALBG ,NANGL ,NSOUTO,NVOUTO,MXSEG,IMERGE)
+ ENDIF
+ DEALLOCATE(MIXN,IMERGE)
+ IF(IPRINT .GE. 1) THEN
+ WRITE(IOUT,6001) NAMSBR
+ ENDIF
+ RETURN
+*----
+* FORMATS
+*----
+ 6000 FORMAT('(* Output from --',A6,'-- follows ')
+ 6001 FORMAT(' Output from --',A6,'-- completed *)')
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 15:19:48 +0000