From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001 From: stainer_t Date: Mon, 8 Sep 2025 13:48:49 +0200 Subject: Initial commit from Polytechnique Montreal --- Dragon/src/XDRLGS.f | 300 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 300 insertions(+) create mode 100644 Dragon/src/XDRLGS.f (limited to 'Dragon/src/XDRLGS.f') diff --git a/Dragon/src/XDRLGS.f b/Dragon/src/XDRLGS.f new file mode 100644 index 0000000..e91b8f6 --- /dev/null +++ b/Dragon/src/XDRLGS.f @@ -0,0 +1,300 @@ +*DECK XDRLGS + SUBROUTINE XDRLGS(IPLIB ,IGS ,IPRINT,MINLEG,MAXLEG,IORD , + > NGROUP,XSREC ,SCAT ,ITYPRO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Get/save Legendre-dependent cross section data from/on IPLIB. +* +*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): G. Marleau +* +*Parameters: input +* IPLIB pointer to the internal library. +* IGS get or save flag: +* >0 save; +* <0 get. +* IPRINT Print level (cross sections printed if IPRINT>99). +* MINLEG mimimum Legendre order to process for scattering. +* MAXLEG maximum Legendre order to process for scattering. +* IORD cross section order: +* =1 constant; +* =2 linear; +* =3 quadratic. +* NGROUP number of energy groups. +* +*Parameters: input/output +* XSREC cross section records (scattering cross section of +* order MINLEG to MAXLEG for IRPROC=MINLEG+1,MAXLEG+1). +* SCAT complete scattering matrix (SCAT(JG,IG) is from IG to JG +* for order MINLEG to MAXLEG). +* +*Parameters: output +* ITYPRO vector for cross section processed indices: +* =0 absent (not processed); +* >0 present (processed). +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPLIB + INTEGER IGS,IPRINT,MINLEG,MAXLEG,IORD,NGROUP, + > ITYPRO(MAXLEG-MINLEG+1) + REAL XSREC(NGROUP,MAXLEG-MINLEG+1), + > SCAT(NGROUP,NGROUP,MAXLEG-MINLEG+1) +*---- +* LOCAL PARAMETERS +* SCATTERING CROSS SECTIONS START AT MINLEG+1 WITH +* NAME NAMSCT='SIGS'//NAMLEG AND NAMSCT='SCAT'//NAMLEG +* WITH NAMLEG DEFINED BY +* WRITE(NAMLEG ,'(I2.2)') ILEG +* FOR ILEG=MINLEG+1 TO MAXLEG+1 +*---- + INTEGER IOUT,MAXGAR + PARAMETER (IOUT=6,MAXGAR=100) + INTEGER NPROC,IGAR(MAXGAR),IODIV,LONG,ITYP,LONG2,ILEG, + > IXSR,IXSTN,IG,JG,NXSCMP,IGTO,IGMIN,IGMAX,IGFROM + CHARACTER*12 NAMXS + CHARACTER NAMLEG*2,NORD*6,HCM(0:10)*2 + INTEGER, ALLOCATABLE, DIMENSION(:) :: NJJ,IJJ + REAL, ALLOCATABLE, DIMENSION(:) :: XSSCMP + DATA HCM /'00','01','02','03','04','05','06','07','08', + > '09','10'/ +*---- +* SCRATCH STORAGE ALLOCATION +*---- + ALLOCATE(NJJ(NGROUP),IJJ(NGROUP),XSSCMP(NGROUP*NGROUP)) +* + IODIV=0 + IF(IORD.EQ.1) THEN + NORD=' ' + IODIV=1 + ELSE IF(IORD.EQ.2) THEN + NORD=' LIN' + IODIV=2 + ELSE IF(IORD.EQ.3) THEN + NORD=' QUA' + IODIV=4 + ENDIF + NPROC=MAXLEG-MINLEG+1 +*---- +* READ/INITIALIZE STATE VECTORS +*---- + IF(MAXLEG+1.GT.MAXGAR) THEN + WRITE(IOUT,9000) 'SCAT-SAVED',MAXGAR,MAXLEG+1 + CALL XABORT('XDRLGS: INVALID VALUE FOR MAXLEG') + ELSE IF(MAXLEG.LT.MINLEG) THEN + CALL XABORT('XDRLGS: MAXLEG.LT.MINLEG') + ENDIF +* + ITYPRO(:NPROC)=0 + CALL LCMLEN(IPLIB,'SCAT-SAVED',LONG,ITYP) + LONG2=MAX(LONG,MAXLEG+1) + IGAR(:LONG2)=0 + IF(LONG.NE.0) THEN + CALL LCMGET(IPLIB,'SCAT-SAVED',IGAR) + DO 20 ILEG=MINLEG+1,MIN(LONG,MAXLEG+1) + ITYPRO(ILEG-MINLEG)=IGAR(ILEG) + 20 CONTINUE + ELSE IF(IGS.LT.0) THEN + CALL XABORT('XDRLGS: NO SCAT-SAVED RECORD AVAILABLE') + ENDIF +* + IF(IGS.GT.0) THEN +*---- +* SAVE LOCAL SCATTERING MATRIX +*---- + IXSR=0 + DO 120 ILEG=MINLEG+1,MAXLEG+1 + IXSR=IXSR+1 + IXSTN=MOD(ITYPRO(IXSR)/IODIV,2) +*---- +* FIND IF SCATTERING XS NOT ALL 0.0 +*---- + IF((ILEG.EQ.1).AND.(IODIV.EQ.1)) THEN + IF(IXSTN.EQ.0) THEN + ITYPRO(IXSR)=ITYPRO(IXSR)+IODIV + IGAR(ILEG)=IGAR(ILEG)+IODIV + IXSTN=1 + ENDIF + ELSE + DO 130 IG=1,NGROUP + DO 131 JG=1,NGROUP + IF(SCAT(IG,JG,IXSR).NE.0.0) THEN + IF(IXSTN.EQ.0) THEN + ITYPRO(IXSR)=ITYPRO(IXSR)+IODIV + IGAR(ILEG)=IGAR(ILEG)+IODIV + IXSTN=1 + ENDIF + GO TO 135 + ENDIF + 131 CONTINUE + 130 CONTINUE + ENDIF + 135 IF(IXSTN.NE.0) THEN + IF(ILEG.LE.11) THEN + NAMLEG=HCM(ILEG-1) + ELSE + WRITE(NAMLEG,'(I2.2)') ILEG-1 + ENDIF + CALL LCMPUT(IPLIB,'SIGS'//NAMLEG//NORD,NGROUP,2, + > XSREC(1,IXSR)) +*---- +* COMPRESS SCATTERING MATRIX +* SCAT(IGTO,IGFROM) REPRESENT SCATTERING CROSS SECTION +* FROM GROUP "IGFROM" TO GROUP "IGTO" +* IJJ(IGTO) IS MAXIMUM GROUP NUMBER +* WITH SCATTERING TO "IGTO" GROUP +* NJJ(IGTO) IS NUMBER OF GROUPS +* WITH SCATTERING TO "IGTO" GROUP +* XSSCMP(IX) IS COMPRESSED SCATTERING MATRIX +* IX CAN BE LOCALIZED IN SCAT(IGTO,IGFROM) USING +* IF(IGTO=1) THEN +* IPOSD=1 +* ELSE +* IPOSD=1+SUM( NJJ(IGF) , IGF=1,IGTO-1) +* ENDIF +* IF(IGFROM.GT.IJJ(IGTO)) THEN +* XSSCMP NOT STORED +* ELSE IF(IGFROM.LT.IJJ(IGTO)-NJJ(IGTO)+1) THEN +* XSSCMP NOT STORED +* ELSE +* IX=IPOSD+IJJ(IGTO)-IGFROM +* XSSCMP(IX)=SCAT(IGTO,IGFROM) +* ENDIF +*---- + NXSCMP=0 + DO 140 IGTO=1,NGROUP + IGMIN=IGTO + IGMAX=IGTO + DO 150 IGFROM=1,NGROUP + IF(SCAT(IGTO,IGFROM,IXSR).NE.0.0) THEN + IGMIN=MIN(IGMIN,IGFROM) + IGMAX=MAX(IGMAX,IGFROM) + ENDIF + 150 CONTINUE + IJJ(IGTO)=IGMAX + NJJ(IGTO)=IGMAX-IGMIN+1 + DO 160 IGFROM=IGMAX,IGMIN,-1 + NXSCMP=NXSCMP+1 + XSSCMP(NXSCMP)=SCAT(IGTO,IGFROM,IXSR) + 160 CONTINUE + 140 CONTINUE + CALL LCMPUT(IPLIB,'NJJS'//NAMLEG//NORD,NGROUP,1,NJJ) + CALL LCMPUT(IPLIB,'IJJS'//NAMLEG//NORD,NGROUP,1,IJJ) + CALL LCMPUT(IPLIB,'SCAT'//NAMLEG//NORD,NXSCMP,2,XSSCMP) + ENDIF + 120 CONTINUE + CALL LCMPUT(IPLIB,'SCAT-SAVED',LONG2,1,IGAR) + ELSE +*---- +* GET LOCAL SCATTERING MATRIX +*---- + IXSR=0 + DO 220 ILEG=MINLEG+1,MAXLEG+1 + IXSR=IXSR+1 +*---- +* READ IF IXSTN = 1 +* INITIALIZE TO 0.0 IF IXSTN = 0 +*---- + XSREC(:NGROUP,IXSR)=0.0 + SCAT(:NGROUP,:NGROUP,IXSR)=0.0 + IXSTN=MOD(ITYPRO(IXSR)/IODIV,2) + IF(IXSTN.EQ.1) THEN + IF(ILEG.LE.11) THEN + NAMLEG=HCM(ILEG-1) + ELSE + WRITE(NAMLEG,'(I2.2)') ILEG-1 + ENDIF + CALL LCMGET(IPLIB,'SIGS'//NAMLEG//NORD,XSREC(1,IXSR)) + CALL LCMGET(IPLIB,'NJJS'//NAMLEG//NORD,NJJ) + CALL LCMGET(IPLIB,'IJJS'//NAMLEG//NORD,IJJ) + CALL LCMGET(IPLIB,'SCAT'//NAMLEG//NORD,XSSCMP) +*---- +* DECOMPRESS SCATTERING MATRIX +* SCAT(IGTO,IGFROM) REPRESENT SCATTERING CROSS SECTION +* FROM GROUP "IGFROM" TO GROUP "IGTO" +* IJJ(IGTO) IS MAXIMUM GROUP NUMBER +* WITH SCATTERING TO "IGTO" GROUP +* NJJ(IGTO) IS NUMBER OF GROUPS +* WITH SCATTERING TO "IGTO" GROUP +* XSSCMP(IX) IS COMPRESSED SCATTERING MATRIX +* SCAT(IGTO,IGFROM) CAN BE LOCALIZED IN XSSCMP(IX) USING +* IF(IGTO=1) THEN +* IPOSD=1 +* ELSE +* IPOSD=1+SUM( NJJ(IGF) , IGF=1,IGTO-1) +* ENDIF +* IF(IGFROM.GT.IJJ(IGTO)) THEN +* SCAT(IGTO,IGFROM)=0.0 +* ELSE IF(IGFROM.LT.IJJ(IGTO)-NJJ(IGTO)+1) THEN +* SCAT(IGTO,IGFROM)=0.0 +* ELSE +* SCAT(IGTO,IGFROM)=XSSCMP(IPOSD+IJJ(IGTO)-IGFROM) +* ENDIF +*---- + NXSCMP=0 + DO 240 IGTO=1,NGROUP + IGMAX=IJJ(IGTO) + IGMIN=IGMAX-NJJ(IGTO)+1 + DO 250 IGFROM=IGMAX,IGMIN,-1 + NXSCMP=NXSCMP+1 + SCAT(IGTO,IGFROM,IXSR)=XSSCMP(NXSCMP) + 250 CONTINUE + 240 CONTINUE + ENDIF + 220 CONTINUE + ENDIF + IF(IPRINT .GE. 100) THEN +*---- +* Print XS +*---- + IXSR=0 + DO ILEG=MINLEG+1,MAXLEG+1 + IXSR=IXSR+1 + IXSTN=MOD(ITYPRO(ILEG)/IODIV,2) + IF(IXSTN.NE.0) THEN + WRITE(NAMXS,'(A4,I2.2,A6)') 'SIGS',ILEG-1,NORD + WRITE(IOUT,6000) NAMXS + WRITE(IOUT,6010) (XSREC(IG,IXSR),IG=1,NGROUP) +*---- +* SCAT(IGTO,IGFROM) REPRESENT SCATTERING CROSS SECTION +* FROM GROUP "IGFROM" TO GROUP "IGTO" +*---- + WRITE(NAMXS,'(A4,I2.2,A6)') 'SCAT',ILEG-1,NORD + WRITE(IOUT,6000) NAMXS + DO IGFROM=1,NGROUP + WRITE(IOUT,6001) IGFROM + WRITE(IOUT,6010) (SCAT(IGTO,IGFROM,IXSR),IGTO=1,NGROUP) + ENDDO + ENDIF + ENDDO + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(XSSCMP,IJJ,NJJ) + RETURN +*---- +* ABORT FORMAT +*---- + 6000 FORMAT(/' CROSS SECTION TYPE = ',A12) + 6001 FORMAT(/' SCATTERING FROM GROUP = ',I10) + 6010 FORMAT(1P,5E16.7) + 9000 FORMAT(/' XDRLGS: ****** ABORT ******'/ + > ' INVALID LENGTH OF RECORD ',A10/ + > ' STORAGE SPACE = ',I10/ + > ' LENGTH OF RECORD LONG = ',I10/ + > ' ***************************') + END -- cgit v1.2.3