diff options
Diffstat (limited to 'Trivac/src/FLDBSM.f')
| -rwxr-xr-x | Trivac/src/FLDBSM.f | 184 |
1 files changed, 184 insertions, 0 deletions
diff --git a/Trivac/src/FLDBSM.f b/Trivac/src/FLDBSM.f new file mode 100755 index 0000000..374a28c --- /dev/null +++ b/Trivac/src/FLDBSM.f @@ -0,0 +1,184 @@ +*DECK FLDBSM + SUBROUTINE FLDBSM(NAMP,IPTRK,IPSYS,LL4,NBMIX,NAN,F2,F3) +* +*----------------------------------------------------------------------- +* +*Purpose: +* LCM driver for the multiplication of a matrix by a vector. +* Special version for the simplified PN method in BIVAC. +* +*Copyright: +* Copyright (C) 2004 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 +* NAMP name of the coefficient matrix. +* IPTRK L_TRACK pointer to the tracking information. +* IPSYS L_SYSTEM pointer to system matrices. +* LL4 order of the matrix. +* NBMIX total number of material mixtures in the macrolib. +* NAN number of Legendre orders in the cross sections. +* F2 vector to multiply. +* +*Parameters: output +* F3 result of the multiplication. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER NAMP*(*) + TYPE(C_PTR) IPTRK,IPSYS + INTEGER LL4,NBMIX,NAN + REAL F2(LL4),F3(LL4) +*---- +* LOCAL VARIABLES +*---- + PARAMETER (NSTATE=40) + CHARACTER NAMT*12,TEXT12*12 + INTEGER IPAR(NSTATE) + INTEGER, DIMENSION(:), ALLOCATABLE :: MAT,KN,IQFR,IPERT + REAL, DIMENSION(:), ALLOCATABLE :: VOL,QFR,XX,YY,GAMMA + REAL, DIMENSION(:,:), ALLOCATABLE :: SGD,V,R,H + INTEGER, DIMENSION(:), POINTER :: MU + REAL, DIMENSION(:), POINTER :: ASS + TYPE(C_PTR) MU_PTR,ASS_PTR +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(SGD(NBMIX,2*NAN)) +*---- +* RECOVER ENERGY GROUP INDICES. +*---- + NAMT=NAMP + READ(NAMT,'(1X,2I3)') IGR,JGR +*---- +* RECOVER PN SPECIFIC PARAMETERS. +*---- + CALL LCMGET(IPTRK,'STATE-VECTOR',IPAR) + NREG=IPAR(1) + NUN=IPAR(2) + ITYPE=IPAR(6) + IELEM=IPAR(8) + ICOL=IPAR(9) + ISPLH=IPAR(10) + L4=IPAR(11) + LX=IPAR(12) + NLF=IPAR(14) + ISPN=IPAR(15) + NVD=IPAR(17) + IF(ITYPE.EQ.8) THEN + IF(NUN.GT.(LX+L4)*NLF/2) CALL XABORT('FLDBSM: INVALID NUN OR ' + 1 //'L4.') + ELSE + IF(NUN.NE.L4*NLF/2) CALL XABORT('FLDBSM: INVALID NUN OR L4.') + ENDIF + IF(L4*NLF/2.NE.LL4) CALL XABORT('FLDBSM: INVALID L4 OR LL4.') +*---- +* PROCESS A FISSION MATRIX. +*---- + IF(NAMT(1:1).EQ.'B') THEN + CALL LCMLEN(IPTRK,'MU',LL4TS,ITYLCM) + IF(L4.NE.LL4TS) CALL XABORT('FLDBSM: INVALID L4.') + CALL LCMGPD(IPTRK,'MU',MU_PTR) + CALL LCMGPD(IPSYS,NAMT,ASS_PTR) + CALL C_F_POINTER(MU_PTR,MU,(/ LL4 /)) + CALL C_F_POINTER(ASS_PTR,ASS,(/ MU(L4) /)) + CALL ALLDLM(L4,ASS,F2,F3,MU,1) + RETURN + ELSE IF(NAMT(1:1).NE.'A') THEN + CALL XABORT('FLDBSM: ''A'' OR ''B'' MATRIX EXPECTED.') + ENDIF +*---- +* RECOVER TRACKING INFORMATION. +*---- + ALLOCATE(MAT(NREG),VOL(NREG)) + CALL LCMGET(IPTRK,'MATCOD',MAT) + CALL LCMGET(IPTRK,'VOLUME',VOL) + CALL LCMLEN(IPTRK,'KN',MAXKN,ITYLCM) + CALL LCMLEN(IPTRK,'QFR',MAXQF,ITYLCM) + ALLOCATE(KN(MAXKN),QFR(MAXQF),IQFR(MAXQF)) + CALL LCMGET(IPTRK,'KN',KN) + CALL LCMGET(IPTRK,'QFR',QFR) + CALL LCMGET(IPTRK,'IQFR',IQFR) +*---- +* PROCESS PHYSICAL ALBEDOS +*---- + TEXT12='ALBEDO-FU'//NAMT(2:4) + CALL LCMLEN(IPSYS,TEXT12,NALBP,ITYLCM) + IF(NALBP.GT.0) THEN + ALLOCATE(GAMMA(NALBP)) + CALL LCMGET(IPSYS,TEXT12,GAMMA) + DO IQW=1,MAXQF + IALB=IQFR(IQW) + IF(IALB.NE.0) QFR(IQW)=QFR(IQW)*GAMMA(IALB) + ENDDO + DEALLOCATE(GAMMA) + ENDIF +*---- +* RECOVER THE CROSS SECTIONS. +*---- + DO 20 IL=1,NAN + WRITE(TEXT12,'(4HSCAR,I2.2,A6)') IL-1,NAMT(2:7) + CALL LCMLEN(IPSYS,TEXT12,LENGT,ITYLCM) + IF(LENGT.EQ.0) THEN + SGD(:NBMIX,IL)=0.0 + SGD(:NBMIX,NAN+IL)=0.0 + ELSE + CALL LCMGET(IPSYS,TEXT12,SGD(1,IL)) + WRITE(TEXT12,'(4HSCAI,I2.2,A6)') IL-1,NAMT(2:7) + CALL LCMGET(IPSYS,TEXT12,SGD(1,NAN+IL)) + ENDIF + 20 CONTINUE +*---- +* RECOVER THE FINITE ELEMENT UNIT STIFFNESS MATRIX. +*---- + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMLEN(IPTRK,'T',LC,ITYLCM) + ALLOCATE(R(LC,LC),V(LC,LC-1)) + CALL LCMGET(IPTRK,'R',R) + CALL LCMGET(IPTRK,'V',V) + CALL LCMSIX(IPTRK,' ',2) +*---- +* COMPUTE THE SOURCE +*---- + ITY=0 + IF(IGR.NE.JGR) ITY=1 + IF((ITYPE.EQ.2).OR.((ITYPE.EQ.5).AND.(ISPN.EQ.1))) THEN + ALLOCATE(XX(NREG),YY(NREG)) + CALL LCMGET(IPTRK,'XX',XX) + CALL LCMGET(IPTRK,'YY',YY) + CALL PNSZ2D(ITY,NREG,IELEM,ICOL,XX,YY,MAT,VOL,NBMIX,NLF,NVD, + 1 NAN,SGD(1,1),SGD(1,NAN+1),L4,KN,QFR,LC,R,V,F2,F3) + DEALLOCATE(YY,XX) + ELSE IF(ITYPE.EQ.8) THEN + NBLOS=LX/3 + CALL LCMGET(IPTRK,'SIDE',SIDE) + ALLOCATE(IPERT(NBLOS),H(LC,LC-1)) + CALL LCMGET(IPTRK,'IPERT',IPERT) + CALL LCMSIX(IPTRK,'BIVCOL',1) + CALL LCMGET(IPTRK,'H',H) + CALL LCMSIX(IPTRK,' ',2) + CALL PNSH2D(ITY,IELEM,ICOL,NBLOS,SIDE,MAT,NBMIX,NLF,NVD, + 1 NAN,SGD(1,1),L4,IPERT,KN,QFR,LC,R,V,H,F2,F3) + DEALLOCATE(H,IPERT) + ENDIF + IF(ITY.EQ.1) THEN + DO 30 I=1,LL4 + F3(I)=-F3(I) + 30 CONTINUE + ENDIF + DEALLOCATE(V,R,IQFR,QFR,KN,VOL,MAT) +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(SGD) + RETURN + END |