Initial commit from Polytechnique Montreal

1 files changed, 192 insertions, 0 deletions

diff --git a/Dragon/src/CPOLGX.f b/Dragon/src/CPOLGX.f
new file mode 100644
index 0000000..ac5e44b
--- /dev/null
+++ b/Dragon/src/CPOLGX.f
@@ -0,0 +1,192 @@
+*DECK CPOLGX
+      SUBROUTINE CPOLGX(IPLIB ,IGS   ,IPRINT,IORD  ,NGROUP,INDPRO,
+     >                  XSREC ,ITYPRO)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Get/save standard vectorial cross section data from/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
+* IPLIB   pointer to the internal library.
+* IGS     get or save flag:
+*         >0 save;
+*         <0 get.
+* IPRINT  Print level (cross sections printed if IPRINT>99).
+* IORD    cross section order:
+*         =1 constant;
+*         =2 linear;
+*         =3 quadratic.
+* NGROUP  number of energy groups.
+* INDPRO  vector for cross section to process:
+*         =0 do not process;
+*         >0 process.
+*
+*Parameters: input/output
+* XSREC   cross section table.
+*
+*Parameters: output
+* ITYPRO  vector for cross section processed indices:
+*         =0 absent  (not processed);
+*         >0 present (processed).
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      IMPLICIT NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      INTEGER          NDPROC
+      PARAMETER       (NDPROC=20)
+      TYPE(C_PTR)      IPLIB
+      INTEGER          IGS,IPRINT,IORD,NGROUP,INDPRO(NDPROC),
+     >                 ITYPRO(NDPROC)
+      REAL             XSREC(NGROUP,NDPROC)
+*----
+*  LOCAL PARAMETERS
+*  NDPROC = NUMBER OF DEFAULT CROSS SECTIONS = 20
+*  NAMDXS = NAME OF NDPROC DEFAULT XS
+*----
+      INTEGER          IOUT
+      PARAMETER       (IOUT=6)
+      CHARACTER        NAMDXS(NDPROC)*6,NORD*6,TEXT6*6,TEXT12*12,NAMT*12
+      INTEGER          IODIV,LONG,ITYP,IXSR,IXSTN,IG,JG
+      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'/
+      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
+*----
+*  READ/INITIALIZE STATE VECTOR
+*----
+      CALL LCMLEN(IPLIB,'XS-SAVED',LONG,ITYP)
+      IF(LONG.EQ.NDPROC) THEN
+        CALL LCMGET(IPLIB,'XS-SAVED',ITYPRO)
+      ELSE IF(LONG.EQ.0) THEN
+        ITYPRO(:NDPROC)=0
+        NAMT=' '
+        CALL LCMNXT(IPLIB,NAMT)
+        TEXT12=NAMT
+   80   CALL LCMLEN(IPLIB,NAMT,LONG,ITYP)
+        IF(ITYP.EQ.2) THEN
+           DO 90 IXSR=1,NDPROC
+           IF(NAMT(:6).EQ.NAMDXS(IXSR)) ITYPRO(IXSR)=1
+   90      CONTINUE
+        ENDIF
+        CALL LCMNXT(IPLIB,NAMT)
+        IF(NAMT.NE.TEXT12) GO TO 80
+      ELSE
+        WRITE(IOUT,9000) NDPROC,LONG
+        CALL XABORT('CPOLGX: INVALID VALUE FOR NDPROC')
+      ENDIF
+      IF(IGS.GT.0) THEN
+*----
+*  SAVE LOCAL DEFAULT XS IF REQUIRED
+*----
+        IF(IGS.EQ.1) THEN
+          DO 100 IXSR=1,NDPROC
+            TEXT6=NAMDXS(IXSR)
+            IF(IXSR.EQ.1) TEXT6='TOTAL'
+            IF(INDPRO(IXSR).EQ.1) THEN
+              IXSTN=MOD(ITYPRO(IXSR)/IODIV,2)
+*----
+*  FIND IF XS NOT ALL 0.0
+*----
+              DO 110 IG=1,NGROUP
+                IF(XSREC(IG,IXSR).NE.0.0) THEN
+                  IF(IXSTN.EQ.0) THEN
+                    ITYPRO(IXSR)=ITYPRO(IXSR)+IODIV
+                    IXSTN=1
+                  ENDIF
+                  GO TO 115
+                ENDIF
+ 110          CONTINUE
+ 115          CONTINUE
+              IF((IXSTN.NE.0).OR.(IXSR.EQ.2)) THEN
+                CALL LCMPUT(IPLIB,TEXT6//NORD,NGROUP,2,XSREC(1,IXSR))
+              ENDIF
+            ENDIF
+ 100      CONTINUE
+        ENDIF
+        CALL LCMPUT(IPLIB,'XS-SAVED',NDPROC,1,ITYPRO)
+      ELSE
+*----
+*  GET LOCAL DEFAULT XS IF REQUIRED
+*----
+        IF(IGS.EQ.-1) THEN
+          DO 200 IXSR=1,NDPROC
+            TEXT6=NAMDXS(IXSR)
+            IF(IXSR.EQ.1) TEXT6='NTOT0'
+            IF(INDPRO(IXSR).EQ.1) THEN
+              IXSTN=MOD(ITYPRO(IXSR)/IODIV,2)
+*----
+*  READ IF IXSTN = 1
+*  INITIALIZE TO 0.0 IF IXSTN = 0
+*----
+              IF(IXSTN.EQ.1) THEN
+                CALL LCMLEN(IPLIB,TEXT6//NORD,LONG,ITYP)
+                IF(LONG .EQ. 0) THEN 
+                  XSREC(:NGROUP,IXSR)=0.0
+                ELSE
+                  CALL LCMGET(IPLIB,TEXT6//NORD,XSREC(1,IXSR))
+                ENDIF
+              ELSE
+                XSREC(:NGROUP,IXSR)=0.0
+              ENDIF
+            ENDIF
+ 200      CONTINUE
+        ENDIF
+      ENDIF
+      IF(IPRINT .GE. 100) THEN
+*----
+*  Print XS
+*----
+        DO IXSR=1,NDPROC
+          IF(INDPRO(IXSR).EQ.1) THEN
+            IXSTN=MOD(ITYPRO(IXSR)/IODIV,2)
+            IF(IXSTN.NE.0) THEN
+              DO IG=1,NGROUP
+                IF(XSREC(IG,IXSR).NE.0.0) THEN
+                  WRITE(IOUT,6000) NAMDXS(IXSR)//NORD
+                  WRITE(IOUT,6010) (XSREC(JG,IXSR),JG=1,NGROUP)
+                  GO TO 210
+                ENDIF
+              ENDDO
+            ENDIF
+ 210        CONTINUE
+          ENDIF
+        ENDDO
+      ENDIF
+      RETURN
+*----
+*  ABORT FORMAT
+*----
+ 9000 FORMAT(' CPOLGX: ****** ABORT ******'/
+     >       ' INVALID LENGTH OF RECORD XS-SAVED '/
+     >       ' STORAGE SPACE NDPROC   = ',I10/
+     >       ' LENGTH OF RECORD LONG  = ',I10/
+     >       ' ***************************')
+ 6000 FORMAT(/' CROSS SECTION TYPE    = ',A12)
+ 6010 FORMAT(1P,5E16.7)
+      END