summaryrefslogtreecommitdiff
path: root/Dragon/src/FMTSUS.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/FMTSUS.f')
-rw-r--r--Dragon/src/FMTSUS.f208
1 files changed, 208 insertions, 0 deletions
diff --git a/Dragon/src/FMTSUS.f b/Dragon/src/FMTSUS.f
new file mode 100644
index 0000000..6777fd9
--- /dev/null
+++ b/Dragon/src/FMTSUS.f
@@ -0,0 +1,208 @@
+*DECK FMTSUS
+ SUBROUTINE FMTSUS(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY,SENTRY,
+ > IPRINT,NOPT,IOPT)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* To prepare information for the SUS3D code.
+*
+*Copyright:
+* Copyright (C) 2008 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
+* NENTRY number of data structures transfered to this module.
+* HENTRY name of the data structures.
+* IENTRY data structure type where:
+* =1 for LCM memory object;
+* =2 for XSM file;
+* =3 for sequential binary file;
+* =4 for sequential ASCII file.
+* JENTRY access permission for the data structure where:
+* =0 for a data structure in creation mode;
+* =1 for a data structure in modifications mode;
+* =2 for a data structure in read-only mode.
+* KENTRY data structure pointer.
+* SENTRY data structure signature.
+* IPRINT print level.
+* NOPT number of options.
+* IOPT processing option.
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+ IMPLICIT NONE
+*----
+* Subroutine arguments
+*----
+ INTEGER NENTRY
+ CHARACTER HENTRY(NENTRY)*12
+ TYPE(C_PTR) KENTRY(NENTRY)
+ INTEGER IENTRY(NENTRY),JENTRY(NENTRY)
+ CHARACTER SENTRY(NENTRY)*12
+ INTEGER IPRINT,NOPT,IOPT(NOPT)
+*----
+* Local parameters
+*----
+ INTEGER IOUT
+ CHARACTER NAMSBR*6
+ PARAMETER (IOUT=6,NAMSBR='FMTSUS')
+ INTEGER ILCMUP,ILCMDN
+ PARAMETER (ILCMUP=1,ILCMDN=2)
+ INTEGER NSTATE
+ PARAMETER (NSTATE=40)
+*----
+* Local variables
+*----
+ INTEGER IEN,IKFLU,IKTRK
+ CHARACTER HSIGN*12
+ INTEGER ISTATE(NSTATE)
+ INTEGER NTREG,NTUNK,NTANI,ITROP,LTRK,
+ > AZMOAQ,AZMQUA,POLQUA,POLOAQ
+ INTEGER NDIM
+ INTEGER ISADJ,NGROUP,NREG,NBAQU
+ INTEGER LCMLN,LCMTY
+*----
+* Allocatable arrays
+*----
+ REAL, ALLOCATABLE, DIMENSION(:) :: VOLUME,XPOL,WPOL,XAZI,WAZI,
+ > FLUX,WGHT,MU,ETA
+ DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: XDAZI,WDAZI,AFLUX,
+ > TFLUX
+*----
+* Validate entry parameters
+*----
+ IF(NENTRY .LT. 5) CALL XABORT(NAMSBR//
+ > ': At least five data structures required for this option.')
+*----
+* Output structure
+*----
+ IKTRK=0
+ IEN=1
+ IF(IENTRY(IEN) .EQ. 4) THEN
+ IF(JENTRY(IEN) .EQ. 2) CALL XABORT(NAMSBR//
+ > ': Data structure not in update or creation mode.')
+ IF(JENTRY(IEN) .EQ. 1) REWIND(FILUNIT(KENTRY(IEN)))
+ ELSE
+ CALL XABORT(NAMSBR//
+ > ': Invalid data structure format for '//HENTRY(IEN)//'.')
+ ENDIF
+ DO IEN=2,3
+ IF(IENTRY(IEN) .EQ. 3 .OR. IENTRY(IEN) .EQ. 4) THEN
+ IF(JENTRY(IEN) .EQ. 2) CALL XABORT(NAMSBR//
+ > ': Data structure not in update or creation mode.')
+ IF(JENTRY(IEN) .EQ. 1) REWIND(FILUNIT(KENTRY(IEN)))
+ ELSE
+ CALL XABORT(NAMSBR//
+ > ': Invalid data structure format for '//HENTRY(IEN)//'.')
+ ENDIF
+ ENDDO
+*----
+* Input structure
+*----
+ DO IEN=4,NENTRY
+ IF(IENTRY(IEN) .EQ. 1 .OR. IENTRY(IEN) .EQ. 2) THEN
+ IF(JENTRY(IEN) .NE. 2) CALL XABORT(NAMSBR//
+ > ': Data structure not in read-only mode.')
+ IF(SENTRY(IEN) .EQ. 'L_FLUX') THEN
+ IKFLU=IEN
+ ELSE IF(SENTRY(IEN) .EQ. 'L_TRACK') THEN
+ IKTRK=IEN
+ CALL LCMGTC(KENTRY(IEN),'TRACK-TYPE',12,HSIGN)
+ IF(HSIGN .NE. 'EXCELL') CALL XABORT(NAMSBR//
+ > ': Only EXCELL type tracking valid.')
+ ELSE
+ CALL XABORT(NAMSBR//
+ > ': Invalid signature for '//HENTRY(IEN)//'.')
+ ENDIF
+ ELSE
+ CALL XABORT(NAMSBR//
+ > ': Invalid data structure format for '//HENTRY(IEN)//'.')
+ ENDIF
+ ENDDO
+*----
+* Get STATE-VECTOR from FLUX data structure
+*----
+ ISTATE(:NSTATE)=0
+ CALL LCMGET(KENTRY(IKFLU),'STATE-VECTOR',ISTATE)
+ ISADJ=ISTATE(8)
+ NGROUP=ISTATE(9)
+ NREG=ISTATE(10)
+*----
+* Get STATE-VECTOR from VOLTRK data structure
+*----
+ ISTATE(:NSTATE)=0
+ CALL LCMGET(KENTRY(IKTRK),'STATE-VECTOR',ISTATE)
+ NTREG=ISTATE(1)
+ NTUNK=ISTATE(2)
+ NTANI=ISTATE(6)
+ ITROP=ISTATE(7)
+ LTRK=ISTATE(9)
+ AZMOAQ=ISTATE(11)
+ POLQUA=ISTATE(13)
+ POLOAQ=ISTATE(14)
+ AZMQUA=ISTATE(15)
+ IF(NTREG .NE. NTUNK) CALL XABORT(NAMSBR//
+ >': Inconsistent number of regions and unknowns.')
+ IF(NTREG .NE. NREG) CALL XABORT(NAMSBR//
+ >': Number of unknowns in VOLTRK and FLUX inconsistent.')
+ IF(ITROP .NE. 4) CALL XABORT(NAMSBR//
+ >': Only NXT: tracking permitted.')
+ IF(POLQUA .LE. -1) CALL XABORT(NAMSBR//
+ >': No polar quadrature provided.')
+ IF(AZMQUA .LE. 0) CALL XABORT(NAMSBR//
+ >': No azimuthal quadrature provided.')
+ ALLOCATE(VOLUME(NTREG))
+ CALL LCMGET(KENTRY(IKTRK),'VOLUME ',VOLUME)
+ CALL LCMSIX(KENTRY(IKTRK),'NXTRecords ',ILCMUP)
+ ISTATE(:NSTATE)=0
+ CALL LCMGET(KENTRY(IKTRK),'G00000001DIM',ISTATE)
+ NDIM=ISTATE(1)
+*----
+* Allocate memory for direction and weights and read them
+*----
+ CALL LCMLEN(KENTRY(IKTRK),'TrackingTrkW',LCMLN,LCMTY)
+ AZMOAQ=LCMLN/2
+ ALLOCATE(XPOL(2*POLOAQ),WPOL(POLOAQ))
+ ALLOCATE(XDAZI(NDIM*AZMOAQ),WDAZI(AZMOAQ))
+ CALL LCMGET(KENTRY(IKTRK),'TrackingDirc',XDAZI)
+ CALL LCMGET(KENTRY(IKTRK),'TrackingTrkW',WDAZI)
+ CALL LCMGET(KENTRY(IKTRK),'POLAR MU ',XPOL)
+ CALL LCMGET(KENTRY(IKTRK),'POLAR WEIGHT',WPOL)
+ CALL LCMSIX(KENTRY(IKTRK),'NXTRecords ',ILCMDN)
+ ALLOCATE(XAZI(NDIM*AZMOAQ),WAZI(AZMOAQ))
+ CALL XDRSDB(NDIM*AZMOAQ,XAZI,XDAZI,1)
+ CALL XDRSDB(AZMOAQ,WAZI,WDAZI,1)
+ DEALLOCATE(WDAZI,XDAZI)
+*----
+* Allocate memory for integrated and angular flux
+*---
+ NBAQU=POLOAQ*AZMOAQ*2
+ ALLOCATE(FLUX(NREG*2*NGROUP*2),WGHT(POLOAQ*AZMOAQ*2),
+ > MU(POLOAQ*AZMOAQ*2),ETA(POLOAQ*AZMOAQ*2))
+ ALLOCATE(AFLUX(NREG*NBAQU*2*NGROUP),TFLUX((NREG+1)*NBAQU))
+*----
+* Process information
+*----
+ CALL FMTSUD(NENTRY,IENTRY,KENTRY,IPRINT,NOPT,IOPT,IKFLU,
+ > NREG ,NGROUP,NDIM ,POLOAQ,AZMOAQ,
+ > VOLUME,XPOL ,WPOL , XAZI ,WAZI ,
+ > FLUX ,AFLUX ,TFLUX, WGHT ,MU ,ETA )
+*----
+* Release memory and return
+*----
+ DEALLOCATE(ETA,MU,WGHT,TFLUX,AFLUX,FLUX,WAZI,XAZI,WPOL,XPOL,
+ > VOLUME)
+ RETURN
+*----
+* Warning formats
+*----
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 11:33:03 +0000