diff options
Diffstat (limited to 'Trivac/src/BIVACA.f')
| -rwxr-xr-x | Trivac/src/BIVACA.f | 212 |
1 files changed, 212 insertions, 0 deletions
diff --git a/Trivac/src/BIVACA.f b/Trivac/src/BIVACA.f new file mode 100755 index 0000000..eeb30a2 --- /dev/null +++ b/Trivac/src/BIVACA.f @@ -0,0 +1,212 @@ +*DECK BIVACA + SUBROUTINE BIVACA(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* BIVAC type (2-D) system matrix assembly operator. +* +*Copyright: +* Copyright (C) 2002 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): create or modification type(L_SYSTEM); +* HENTRY(2): read-only type(L_MACROLIB); +* HENTRY(3): read-only type(L_TRACK). +* 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: +* The BIVACA: calling specifications are: +* SYST := BIVACA: [ SYST} ] MACRO TRACK :: (bivaca\_data) ; +* where +* SYST : name of the \emph{lcm} object (type L\_SYSTEM) containing the +* system matrices. If SYST appears on the RHS, the system matrices +* previously stored in SYST} are kept. +* MACRO : name of the \emph{lcm} object (type L\_MACROLIB) containing the +* macroscopic cross sections and diffusion coefficients. +* TRACK : name of the \emph{lcm} object (type L\_BIVAC) containing the BIVAC +* \emph{tracking}. +* bivaca\_data : structure containing the data to module BIVACA:. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + CHARACTER HENTRY(NENTRY)*12 + TYPE(C_PTR) KENTRY(NENTRY) +*---- +* LOCAL VARIABLES +*---- + PARAMETER(NSTATE=40) + CHARACTER TEXT4*4,HSIGN*12,TEXT12*12,HSMG*131,CNAM*12 + DOUBLE PRECISION DFLOTT + INTEGER IGP(NSTATE),IPAR(NSTATE),IBR(NSTATE) + LOGICAL LDIFF + TYPE(C_PTR) IPSYS,IPMACR,JPMACR,KPMACR,IPTRK + INTEGER, DIMENSION(:), ALLOCATABLE :: MAT + REAL, DIMENSION(:), ALLOCATABLE :: VOL,UN,VII,GAMMA +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.LE.2) CALL XABORT('BIVACA: THREE PARAMETERS EXPECTED.') + IF((IENTRY(1).NE.1).AND.(IENTRY(1).NE.2)) CALL XABORT('BIVACA: L' + 1 //'CM OBJECT EXPECTED AT LHS.') + IF((JENTRY(1).NE.0).AND.(JENTRY(1).NE.1)) CALL XABORT('BIVACA: E' + 1 //'NTRY IN CREATE OR MODIFICATION MODE EXPECTED.') + IF((JENTRY(2).NE.2).OR.((IENTRY(2).NE.1).AND.(IENTRY(2).NE.2))) + 1 CALL XABORT('BIVACA: LCM OBJECT IN READ-ONLY MODE EXPECTED AT S' + 2 //'ECOND RHS.') + IF((JENTRY(3).NE.2).OR.((IENTRY(3).NE.1).AND.(IENTRY(3).NE.2))) + 1 CALL XABORT('BIVACA: LCM OBJECT IN READ-ONLY MODE EXPECTED AT F' + 2 //'IRST RHS.') + CALL LCMGTC(KENTRY(3),'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_TRACK') THEN + TEXT12=HENTRY(3) + CALL XABORT('BIVACA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_TRACK EXPECTED.') + ENDIF + CALL LCMGTC(KENTRY(3),'TRACK-TYPE',12,HSIGN) + IF(HSIGN.NE.'BIVAC') THEN + TEXT12=HENTRY(3) + CALL XABORT('BIVACA: TRACK-TYPE OF '//TEXT12//' IS '//HSIGN// + 1 '. BIVAC EXPECTED.') + ENDIF + HSIGN='L_SYSTEM' + IPSYS=KENTRY(1) + CALL LCMPTC(IPSYS,'SIGNATURE',12,HSIGN) + IPMACR=KENTRY(2) + IPTRK=KENTRY(3) + TEXT12=HENTRY(2) + CALL LCMPTC(IPSYS,'LINK.MACRO',12,TEXT12) + TEXT12=HENTRY(3) + CALL LCMPTC(IPSYS,'LINK.TRACK',12,TEXT12) +*---- +* RECOVER GENERAL TRACKING INFORMATION. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IGP) + NEL=IGP(1) + NLF=IGP(14) + ISCAT=IGP(16) + LDIFF=(ISCAT.LT.0) + ISCAT=ABS(ISCAT) + IF((NLF.NE.0).AND.(IGP(15).NE.1)) CALL XABORT('BIVACA: ONLY SPN ' + 1 //'DISCRETIZATIONS ARE ALLOWED.') + ALLOCATE(MAT(NEL),VOL(NEL)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) +*---- +* RECOVER MACROLIB PARAMETERS. +*---- + CALL LCMGTC(IPMACR,'SIGNATURE',12,HSIGN) + IF(HSIGN.NE.'L_MACROLIB') THEN + TEXT12=HENTRY(2) + CALL XABORT('BIVACA: SIGNATURE OF '//TEXT12//' IS '//HSIGN// + 1 '. L_MACROLIB EXPECTED.') + ENDIF + CALL LCMGET(IPMACR,'STATE-VECTOR',IPAR) + NGRP=IPAR(1) + NBMIX=IPAR(2) + NANI=IPAR(3) + NBFIS=IPAR(4) + NALBP=IPAR(8) + IF(IGP(4).GT.NBMIX) THEN + WRITE(HSMG,'(46HBIVACA: THE NUMBER OF MIXTURES IN THE TRACKING, + 1 2H (,I5,51H) IS GREATER THAN THE NUMBER OF MIXTURES IN THE MAC, + 2 7HROLIB (,I5,2H).)') IGP(4),NBMIX + CALL XABORT(HSMG) + ENDIF +* + IMPX=1 + IUNIT=0 + IOVEL=0 + 10 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.10) GO TO 40 + IF(INDIC.NE.3) CALL XABORT('BIVACA: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('BIVACA: INTEGER DATA EXPECTED(1).') + ELSE IF(TEXT4.EQ.'UNIT') THEN +* COMPUTE THE UNITARY WEIGHTING MATRIX. + IUNIT=1 + ALLOCATE(UN(NBMIX),GAMMA(NALBP)) + UN(:NBMIX)=1.0 + CALL BIVASM('RM',1,IPTRK,IPSYS,IMPX,NBMIX,NEL,0,1,0,MAT,VOL, + 1 GAMMA,UN) + DEALLOCATE(GAMMA,UN) + ELSE IF(TEXT4.EQ.'OVEL') THEN +* COMPUTE THE RECIPROCAL NEUTRON VELOCITIES MATRIX. + IOVEL=1 + JPMACR=LCMGID(IPMACR,'GROUP') + ALLOCATE(VII(NBMIX),GAMMA(NALBP)) + DO 30 IGR=1,NGRP + KPMACR=LCMGIL(JPMACR,IGR) + CALL LCMLEN(KPMACR,'OVERV',LENGT,ITYLCM) + IF(LENGT.EQ.0) THEN + CALL XABORT('BIVACA: NO ''VELOCITY'' INFORMATION.') + ELSE IF(LENGT.GT.NBMIX) THEN + CALL XABORT('BIVACA: INVALID LENGTH FOR ''VELOCITY'' IN' + 1 //'FORMATION.') + ENDIF + CALL LCMGET(KPMACR,'OVERV',VII) + WRITE(CNAM,'(1HV,2I3.3)') IGR,IGR + CALL BIVASM(CNAM,1,IPTRK,IPSYS,IMPX,NBMIX,NEL,0,1,0,MAT,VOL, + 1 GAMMA,VII) + 30 CONTINUE + DEALLOCATE(GAMMA,VII) + ELSE IF(TEXT4.EQ.';') THEN + GO TO 40 + ELSE + CALL XABORT('BIVACA: '//TEXT4//' IS AN INVALID KEY WORD.') + ENDIF + GO TO 10 +*---- +* SET THE STATE VECTOR FOR THE L_SYSTEM OBJECT +*---- + 40 IBR(:NSTATE)=0 + IBR(1)=NGRP + IBR(2)=IGP(11) + IBR(4)=1 + IF(NLF.GT.0) IBR(4)=11 + IF(IUNIT.EQ.1) IBR(5)=1 + IBR(7)=NBMIX + NAN=MIN(ISCAT,NANI) + IBR(8)=NLF + CALL LCMPUT(IPSYS,'STATE-VECTOR',NSTATE,1,IBR) +*---- +* BIVAC SYSTEM MATRIX ASSEMBLY. +*---- + IF(NLF.EQ.0) THEN +* DIFFUSION THEORY. + CALL BIVSYS(IPTRK,IPMACR,IPSYS,IMPX,NGRP,NEL,NBFIS,NALBP,MAT, + 1 VOL,NBMIX) + ELSE +* SIMPLIFIED PN THEORY. + CALL BIVSPS(IPTRK,IPMACR,IPSYS,IMPX,NGRP,NEL,NLF,NAN,NBFIS, + 1 NALBP,LDIFF,MAT,VOL,NBMIX) + ENDIF +* + IF(IMPX.GE.3) CALL LCMLIB(IPSYS) +*---- +* RELEASE GENERAL TRACKING INFORMATION. +*---- + DEALLOCATE(VOL,MAT) + RETURN + END |