Initial commit from Polytechnique Montreal

1 files changed, 161 insertions, 0 deletions

diff --git a/Dragon/src/LIBADJ.f b/Dragon/src/LIBADJ.f
new file mode 100644
index 0000000..0f90281
--- /dev/null
+++ b/Dragon/src/LIBADJ.f
@@ -0,0 +1,161 @@
+*DECK LIBADJ
+      SUBROUTINE LIBADJ (IPLIB,NGRO,NBISO,NL,NDEL,NBESP,IPISO,NED,
+     1 NAMEAD)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Transposition of the usefull interpolated microscopic cross section
+* for producing an adjoint problem.
+*
+*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
+* IPLIB   pointer to the lattice microscopic cross section library
+*         (L_LIBRARY signature).
+* NGRO    number of energy groups.
+* NBISO   number of isotopes present in the calculation domain.
+* NL      number of Legendre orders required in the calculation
+*         NL=1 or higher.
+* NDEL    number of delayed precursor groups.
+* NBESP   number of energy-dependent fission spectra.
+* IPISO   pointer array towards microlib isotopes.
+* NED     number of extra vector edits from matxs.
+* NAMEAD  matxs names of the extra vector edits.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      IMPLICIT NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPLIB,IPISO(NBISO)
+      INTEGER NGRO,NBISO,NL,NDEL,NBESP,NED,NAMEAD(2,NED)
+*----
+*  LOCAL VARIABLES
+*----
+      TYPE(C_PTR) JPLIB
+      INTEGER I,J,I0,IED,IDEL,IL,IMPX,IMT,INGRO,LENGT,ITYLCM
+      REAL SUM
+      CHARACTER TEXT8*8,HNUSIG*12,HCHI*12
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: ITYPRO
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: GA1,GA2,SIGS
+      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: SCAT
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(ITYPRO(NL),GA1(NGRO,2),GA2(NGRO,NGRO),SIGS(NGRO,NL),
+     1 SCAT(NGRO,NGRO,NL))
+*----
+*  ***MATERIAL/ISOTOPE LOOP***
+*----
+      IF(NBESP.NE.0) CALL XABORT('LIBADJ: MULTIPLE FISSION SPECTRA NOT'
+     1 //' IMPLEMENTED.')
+      IMPX=0
+      DO 200 IMT=1,NBISO
+      JPLIB=IPISO(IMT)
+      IF(.NOT.C_ASSOCIATED(JPLIB)) GO TO 200
+      CALL XDRLGS(JPLIB,-1,IMPX,0,NL-1,1,NGRO,SIGS,SCAT,ITYPRO)
+      INGRO=NL-1
+      DO 10 IL=NL-1,0,-1
+      IF(ITYPRO(IL+1).EQ.0) THEN
+         INGRO=INGRO-1
+      ELSE
+         GO TO 20
+      ENDIF
+   10 CONTINUE
+   20 DO 50 IL=0,INGRO
+      IF(ITYPRO(IL+1).GT.0) THEN
+         DO 35 I=1,NGRO
+         GA1(I,1)=SIGS(NGRO-I+1,IL+1)
+         DO 30 J=1,NGRO
+         GA2(I,J)=SCAT(NGRO-J+1,NGRO-I+1,IL+1)
+   30    CONTINUE
+   35    CONTINUE
+         DO 45 I=1,NGRO
+         SIGS(I,IL+1)=GA1(I,1)
+         DO 40 J=1,NGRO
+         SCAT(NGRO-J+1,NGRO-I+1,IL+1)=GA2(J,I)
+   40    CONTINUE
+   45    CONTINUE
+      ENDIF
+   50 CONTINUE
+      CALL XDRLGS(JPLIB,1,IMPX,0,INGRO,1,NGRO,SIGS,SCAT,ITYPRO)
+*
+      CALL LCMLEN(JPLIB,'TRANC',LENGT,ITYLCM)
+      IF (LENGT.GT.0) THEN
+         CALL LCMGET(JPLIB,'TRANC',GA1(1,1))
+         DO 130 I=1,NGRO
+         GA1(I,2)=GA1(NGRO-I+1,1)
+  130    CONTINUE
+         CALL LCMPUT(JPLIB,'TRANC',NGRO,2,GA1(1,2))
+      ENDIF
+*
+      CALL LCMGET(JPLIB,'NTOT0',GA1(1,1))
+      DO 140 I=1,NGRO
+      GA1(I,2)=GA1(NGRO-I+1,1)
+  140 CONTINUE
+      CALL LCMPUT(JPLIB,'NTOT0',NGRO,2,GA1(1,2))
+*
+      DO 175 IDEL=0,NDEL
+      IF(IDEL.EQ.0) THEN
+         HNUSIG='NUSIGF'
+         HCHI='CHI'
+      ELSE
+         WRITE(HNUSIG,'(6HNUSIGF,I2.2)') IDEL
+         WRITE(HCHI,'(3HCHI,I2.2)') IDEL
+      ENDIF
+      CALL LCMLEN(JPLIB,HNUSIG,LENGT,ITYLCM)
+      IF (LENGT.GT.0) THEN
+         CALL LCMGET(JPLIB,HNUSIG,GA1(1,1))
+         SUM=0.0
+         DO 150 I=1,NGRO
+         SUM=SUM+GA1(I,1)
+  150    CONTINUE
+         DO 160 I=1,NGRO
+         GA1(I,2)=GA1(NGRO-I+1,1)/SUM
+  160    CONTINUE
+         CALL LCMGET(JPLIB,HCHI,GA1(1,1))
+         CALL LCMPUT(JPLIB,HCHI,NGRO,2,GA1(1,2))
+         DO 170 I=1,NGRO
+         GA1(I,2)=GA1(NGRO-I+1,1)*SUM
+  170    CONTINUE
+         CALL LCMPUT(JPLIB,HNUSIG,NGRO,2,GA1(1,2))
+      ENDIF
+  175 CONTINUE
+*
+      DO 190 IED=1,NED
+      WRITE(TEXT8,'(2A4)') (NAMEAD(I0,IED),I0=1,2)
+      IF((TEXT8.EQ.'TRANC').OR.(TEXT8.EQ.'NTOT0').OR.
+     1 (TEXT8(:6).EQ.'NUSIGF').OR.(TEXT8(:3).EQ.'CHI'))
+     2 GO TO 190
+      CALL LCMLEN(JPLIB,TEXT8,LENGT,ITYLCM)
+      IF (LENGT.GT.0) THEN
+         CALL LCMGET(JPLIB,TEXT8,GA1(1,1))
+         DO 180 I=1,NGRO
+         GA1(I,2)=GA1(NGRO-I+1,1)
+  180    CONTINUE
+         CALL LCMPUT(JPLIB,TEXT8,NGRO,2,GA1(1,2))
+      ENDIF
+  190 CONTINUE
+  200 CONTINUE
+*
+      CALL LCMGET(IPLIB,'DELTAU',GA1(1,1))
+      DO 210 I=1,NGRO
+      GA1(I,2)=GA1(NGRO-I+1,1)
+  210 CONTINUE
+      CALL LCMPUT(IPLIB,'DELTAU',NGRO,2,GA1(1,2))
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(SCAT,SIGS,GA2,GA1,ITYPRO)
+      RETURN
+      END