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/CPONED.f | 113 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 113 insertions(+) create mode 100644 Dragon/src/CPONED.f (limited to 'Dragon/src/CPONED.f') diff --git a/Dragon/src/CPONED.f b/Dragon/src/CPONED.f new file mode 100644 index 0000000..e1b2db3 --- /dev/null +++ b/Dragon/src/CPONED.f @@ -0,0 +1,113 @@ +*DECK CPONED + SUBROUTINE CPONED(NPROC ,MINLEG,MAXLEG,ILEAKS ,NED ,HVECT , + > IVECT ,INDPRO) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Set up INDPRO for cross section to read on IPLIB. +* +*Copyright: +* Copyright (C) 2007 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 +* NPROC number of terms to process. +* MINLEG mimimum Legendre order to process for scattering. +* MAXLEG maximum Legendre order to process for scattering. +* ILEAKS leakage calculation: = 1 STRD; = 2 STRDX, STRDY and STRDZ. +* NED number of extra vector edits. +* HVECT names of the extra vector edits. +* +*Parameters: output +* IVECT pointer to additional xs possible. +* INDPRO vector for cross section to process: +* = 0 do not process; +* > 0 process. +* +*----------------------------------------------------------------------- +* + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER NPROC ,MINLEG,MAXLEG,ILEAKS,NED,IVECT(NED), + > INDPRO(NPROC) + CHARACTER HVECT(NED)*8 +*---- +* LOCAL PARAMETERS +* NDPROC = NUMBER OF DEFAULT CROSS SECTIONS = 20 +* NAMDXS = NAME OF NDPROC DEFAULT XS +* SCATTERING CROSS SECTIONS START AT NDPROC+1 WITH +* NAME NAMSCT='SIGS'//NAMLEG AND NAMSCT='SCAT'//NAMLEG +* WITH NAMLEG DEFINED BY +* WRITE(NAMLEG ,'(I2.2)') ILEG +* FOR ILEG=0 TO NDPROC-NPROC-1 +*---- + INTEGER NDPROC,IOUT,NEDOTH,IED,IXSR + PARAMETER (NDPROC=20,IOUT=6) + CHARACTER NAMDXS(NDPROC)*6 + SAVE NAMDXS + DATA NAMDXS /'NTOT0 ','TRANC ','NUSIGF','NFTOT ','CHI ', + > 'NU ','NG ','NHEAT ','N2N ','N3N ', + > 'N4N ','NP ','NA ','GOLD ','ABS ', + > 'NWT0 ','STRD ','STRD X','STRD Y','STRD Z'/ +*---- +* SCAN FOR ADDITIONAL AND STANDARD CROSS SECTIONS TO BE SAVED +*---- + IVECT(:NED)=0 + INDPRO(:NPROC)=0 + NEDOTH=NED + DO 100 IED=1,NED + IF(HVECT(IED).EQ.' ') THEN + NEDOTH=NEDOTH-1 + ELSE + DO 110 IXSR=1,NDPROC + IF(HVECT(IED)(:6).EQ.NAMDXS(IXSR)) THEN + NEDOTH=NEDOTH-1 + INDPRO(IXSR)=1 + IF(HVECT(IED).EQ.'NFTOT') GO TO 115 + IVECT(IED)=IXSR + GO TO 115 + ENDIF + 110 CONTINUE + 115 CONTINUE + ENDIF + 100 CONTINUE + IF(NEDOTH.GE.1) THEN + WRITE(IOUT,9000) + DO 120 IED=1,NED + IF(IVECT(IED).EQ.0.AND. + > HVECT(IED).NE.'NFTOT'.AND.HVECT(IED).NE.' ') THEN + WRITE(IOUT,9001) HVECT(IED) + ENDIF + 120 CONTINUE + WRITE(IOUT,9002) + ENDIF + DO 130 IXSR=1,7 + INDPRO(IXSR)=1 + 130 CONTINUE + INDPRO(16)=1 + IF(ILEAKS.EQ.1) THEN + INDPRO(17)=1 + ELSE IF(ILEAKS.EQ.2) THEN + INDPRO(18)=1 + INDPRO(19)=1 + INDPRO(20)=1 + ENDIF + DO 140 IXSR=NDPROC+MINLEG+1,NDPROC+MAXLEG+1 + INDPRO(IXSR)=1 + 140 CONTINUE + RETURN +*---- +* FORMAT +*---- + 9000 FORMAT(' CPONED: ************ WARNING ************') + 9001 FORMAT(' CROSS-SECTION TYPE NOT RECOVERED : ',A8) + 9002 FORMAT(' *****************************************') + END -- cgit v1.2.3