diff options
Diffstat (limited to 'Dragon/src/DMA.f')
| -rw-r--r-- | Dragon/src/DMA.f | 169 |
1 files changed, 169 insertions, 0 deletions
diff --git a/Dragon/src/DMA.f b/Dragon/src/DMA.f new file mode 100644 index 0000000..2212b24 --- /dev/null +++ b/Dragon/src/DMA.f @@ -0,0 +1,169 @@ +*DECK DMA + SUBROUTINE DMA(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Set the source of an adjoint fixed source eigenvalue problem. The +* source is the gradient of a macrolib. +* +*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): A. Hebert +* +*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_SOURCE); +* HENTRY(2): read-only type(L_FLUX); +* HENTRY(3): read-only type(L_MACROLIB); +* HENTRY(4): read-only type(L_TRACKING). +* 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. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) KENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + TYPE(C_PTR) IPDMA,IPFLX,IPMAC,IPTRK + CHARACTER HSIGN*12,TEXT12*12 + INTEGER ISTATE(NSTATE) +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: NAMEAD,NMIX,NDGRP,IMERGE, + 1 IGCR,MAT,KEY + REAL, ALLOCATABLE, DIMENSION(:) :: VOL +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.NE.4) CALL XABORT('DMA: FOUR PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('DMA: LI' + 1 //'NKED LIST OR XSM FILE EXPECTED AT LHS.') + IF(JENTRY(1).NE.0) CALL XABORT('DMA: ENTRY IN CREATE MODE EXPE' + 1 //'CTED.') + DO I=2,4 + IF((JENTRY(I).NE.2).OR.((IENTRY(I).NE.1).AND.(IENTRY(I).NE.2))) + 1 CALL XABORT('DMA: LINKED LIST OR XSM FILE IN READ-ONLY MODE E' + 2 //'XPECTED AT RHS.') + ENDDO + IPDMA=KENTRY(1) + CALL LCMGTC(KENTRY(2),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_FLUX') THEN + TEXT12=HENTRY(2) + CALL XABORT('DMA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_FLUX EXPECTED.') + ENDIF + IPFLX=KENTRY(2) + CALL LCMGTC(KENTRY(3),'SIGNATURE',12,HSIGN) + IF(HSIGN.EQ.'L_MACROLIB') THEN + IPMAC=KENTRY(3) + ELSE IF(HSIGN.EQ.'L_LIBRARY') THEN + IPMAC=LCMGID(KENTRY(3),'MACROLIB') + ELSE + TEXT12=HENTRY(3) + CALL XABORT('DMA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_MACROLIB OR L_LIBRARY EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(4),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(4) + CALL XABORT('DMA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + IPTRK=KENTRY(4) +*---- +* RECOVER STATE VECTOR INFORMATION +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + NREG=ISTATE(1) + NBMIX=ISTATE(4) + CALL LCMGET(IPFLX,'STATE-VECTOR',ISTATE) + NG=ISTATE(1) + NUN=ISTATE(2) + CALL LCMGET(IPMAC,'STATE-VECTOR',ISTATE) + IF(ISTATE(1).NE.NG) CALL XABORT('DMA: INVALID NUMBER OF GROUPS.') + NMIL=ISTATE(2) + NL=ISTATE(3) + NFM=ISTATE(4) + NED=ISTATE(5) + NDEL=ISTATE(7) + ALLOCATE(NAMEAD(2*NED)) + IF(NED.GT.0) CALL LCMGET(IPMAC,'ADDXSNAME-P0',NAMEAD) +*---- +* READ INPUT PARAMETERS +*---- + ALLOCATE(NMIX(NREG)) + CALL LCMGET(IPTRK,'MATCOD',NMIX) + CALL DMAGET(IPDMA,NG,NREG,NBMIX,NMIX,IPRINT,NMERGE,NGCOND) + DEALLOCATE(NMIX) + NCST=(5+NGCOND*NL+2*NFM*(1+NDEL)+NED)*NMERGE*NGCOND +*---- +* COMPUTE THE GPT SOURCE +*---- + ALLOCATE(NDGRP(NG)) + NDGRP(:NG)=0 + ALLOCATE(IMERGE(NREG),IGCR(NG),MAT(NREG),KEY(NREG),VOL(NREG)) + CALL LCMGET(IPDMA,'REF:IMERGE',IMERGE) + CALL LCMGET(IPDMA,'REF:IGCOND',IGCR) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'KEYFLX',KEY) + CALL LCMGET(IPTRK,'VOLUME',VOL) + IOF=1 + JJ=IGCR(1) + DO IND=1,NG + IF(IND.GT.JJ) THEN + IOF=IOF+1 + IF(IOF.GT.NGCOND) CALL XABORT('DMA: NGCOND OVERFLOW.') + JJ=IGCR(IOF) + ENDIF + NDGRP(IND)=IOF + ENDDO + CALL DMASOU(IPRINT,IPDMA,IPMAC,IPFLX,NG,NREG,NMIL,NL,NDEL, + 1 NED,NAMEAD,NUN,NMERGE,NGCOND,NCST,IMERGE,NDGRP,MAT,KEY,VOL) + DEALLOCATE(VOL,KEY,MAT,IGCR,IMERGE) + DEALLOCATE(NDGRP,NAMEAD) +*---- +* SAVE THE SIGNATURE AND STATE VECTOR +*---- + HSIGN='L_SOURCE' + CALL LCMPTC(IPDMA,'SIGNATURE',12,HSIGN) + ISTATE(:NSTATE)=0 + ISTATE(1)=NG + ISTATE(2)=NUN + ISTATE(3)=0 + ISTATE(4)=NCST + ISTATE(5)=NMERGE + ISTATE(6)=NGCOND + IF(IPRINT.GT.0) WRITE(6,100) (ISTATE(I),I=1,6) + CALL LCMPUT(IPDMA,'STATE-VECTOR',NSTATE,1,ISTATE) + RETURN +* + 100 FORMAT(/8H OPTIONS/8H -------/ + 1 7H NG ,I8,28H (NUMBER OF ENERGY GROUPS)/ + 2 7H NUN ,I8,40H (NUMBER OF UNKNOWNS PER ENERGY GROUP)/ + 3 7H NDIR ,I8,35H (NUMBER OF DIRECT FIXED SOURCES)/ + 4 7H NCST ,I8,36H (NUMBER OF ADJOINT FIXED SOURCES)/ + 5 7H NMERGE,I8,34H (NUMBER OF HOMOGENIZED REGIONS)/ + 6 7H NGCOND,I8,38H (NUMBER OF CONDENSED ENERGY GROUPS)) + END |