Initial commit from Polytechnique Montreal

1 files changed, 239 insertions, 0 deletions

diff --git a/Dragon/src/TONCMI.f b/Dragon/src/TONCMI.f
new file mode 100644
index 0000000..6159c09
--- /dev/null
+++ b/Dragon/src/TONCMI.f
@@ -0,0 +1,239 @@
+*DECK TONCMI
+      SUBROUTINE TONCMI(IPMICR,IPRINT,NMERGE,NISOT,NGCOND,NL,NED,NDEL,
+     1 MASKI,SPH)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* SPH-correction of a Microlib.
+*
+*Copyright:
+* Copyright (C) 2017 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
+* IPMICR  pointer to the condensed microlib (L_LIBRARY signature).
+* IPRINT  print flag (equal to 0 for no print).
+* NMERGE  number of merged regions.
+* NISOT   number of isotopes in microlib.
+* NGCOND  number of condensed groups.
+* NL      number of Legendre orders in scattering info.
+* NED     number of additional phi-weighted edits in microlib.
+* NDEL    number of delayed precursor groups.
+* MASKI   isotope mask (=.TRUE. if an isotope is to be corrected).
+* SPH     SPH homogenization factors.
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPMICR
+      INTEGER IPRINT,NMERGE,NISOT,NGCOND,NL,NED,NDEL
+      LOGICAL MASKI(NISOT)
+      REAL SPH(NMERGE,NGCOND)
+*----
+*  LOCAL VARIABLES
+*----
+      PARAMETER(NSTATE=40)
+      INTEGER ISTATE(NSTATE)
+      TYPE(C_PTR) KPMICR
+      CHARACTER HSIGN*12,TEXT12*12,CM*2,TEXT8*8,HSMG*131,HMAKE(100)*12
+      DOUBLE PRECISION DSUM
+*----
+*  ALLOCATABLE ARRAYS
+*----
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: IMIX,ITYPR
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IHUSED,IHEDIT
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: GAR
+      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: WSCAT
+      TYPE(C_PTR), ALLOCATABLE, DIMENSION(:) :: IPISO
+*----
+*  SCRATCH STORAGE ALLOCATION
+*   IHEDIT  character*8 names of phi-weighted edits in microlib.
+*----
+      ALLOCATE(IHEDIT(2,NED+1),ITYPR(NL))
+      ALLOCATE(GAR(NGCOND,10+NL+NED+2*NDEL),WSCAT(NGCOND,NGCOND,NL))
+      ALLOCATE(IHUSED(3,NISOT),IMIX(NISOT),IPISO(NISOT))
+*----
+*  RECOVER MICROLIB INFORMATION
+*----
+      CALL LCMGTC(IPMICR,'SIGNATURE',12,HSIGN)
+      IF(HSIGN.NE.'L_LIBRARY') CALL XABORT('TONCMI: MICROLIB EXPECTED')
+      CALL LCMGET(IPMICR,'STATE-VECTOR',ISTATE)
+      IF(ISTATE(1).NE.NMERGE) CALL XABORT('TONCMI: INVALID NMERGE')
+      IF(ISTATE(2).NE.NISOT) CALL XABORT('TONCMI: INVALID NISOT')
+      IF(ISTATE(3).NE.NGCOND) CALL XABORT('TONCMI: INVALID NGCOND')
+      IF(ISTATE(4).NE.NL) CALL XABORT('TONCMI: INVALID NL')
+      IF(ISTATE(13).NE.NED) CALL XABORT('TONCMI: INVALID NED')
+      IF(ISTATE(19).NE.NDEL) CALL XABORT('TONCMI: INVALID NDEL')
+      IF(NED.GT.0) CALL LCMGET(IPMICR,'ADDXSNAME-P0',IHEDIT)
+*----
+*  LOOP OVER ISOTOPES
+*----
+      CALL LCMGET(IPMICR,'ISOTOPESUSED',IHUSED)
+      CALL LCMGET(IPMICR,'ISOTOPESMIX',IMIX)
+      CALL LIBIPS(IPMICR,NISOT,IPISO)
+      DO 200 ISOT=1,NISOT
+      IF(.NOT.MASKI(ISOT)) GO TO 200
+      WRITE(TEXT12,'(3A4)') (IHUSED(I0,ISOT),I0=1,3)
+      IF(IPRINT.GT.2) THEN
+         WRITE(6,'(29H TONCMI: PROCESSING ISOTOPE '',A12,2H''.)') TEXT12
+      ENDIF
+      IBM=IMIX(ISOT)
+      KPMICR=IPISO(ISOT) ! set ISOT-th isotope
+      IF(.NOT.C_ASSOCIATED(KPMICR)) THEN
+         WRITE(HSMG,'(17HTONCMI: ISOTOPE '',A12,16H'' IS NOT AVAILAB,
+     >   19HLE IN THE MICROLIB.)') TEXT12
+         CALL XABORT(HSMG)
+      ENDIF
+      MAXH=10+NL+NED+2*NDEL
+      IF(MAXH+NL.GT.100) CALL XABORT('TONCMI: STATIC STORAGE EXCEEDED')
+      DO 10 J=1,MAXH+NL
+      HMAKE(J)=' '
+   10 CONTINUE
+      GAR(:NGCOND,:10+NL+NED+2*NDEL)=0.0
+      WSCAT(:NGCOND,:NGCOND,:NL)=0.0
+*----
+*  RECOVER CALCULATION-SPECIFIC ISOTOPIC DATA
+*----
+      CALL LCMGET(KPMICR,'NWT0',GAR(1,1))
+      HMAKE(1)='NWT0'
+      CALL LCMLEN(KPMICR,'NWT1',LENGTH,ITYLCM)
+      IF(LENGTH.EQ.NGCOND) THEN
+         CALL LCMGET(KPMICR,'NWT1',GAR(1,2))
+         HMAKE(2)='NWT1'
+      ENDIF
+      CALL XDRLGS(KPMICR,-1,IPRINT,0,NL-1,1,NGCOND,GAR(1,3),WSCAT,ITYPR)
+      DO 30 IL=0,NL-1
+      IF(ITYPR(IL+1).NE.0) THEN
+         WRITE (CM,'(I2.2)') IL
+         HMAKE(3+IL)='SIGS'//CM
+      ENDIF
+   30 CONTINUE
+      CALL LCMGET(KPMICR,'NTOT0',GAR(1,3+NL))
+      HMAKE(3+NL)='NTOT0'
+      CALL LCMLEN(KPMICR,'NTOT1',LENGTH,ITYLCM)
+      IF(LENGTH.EQ.NGCOND) THEN
+         HMAKE(4+NL)='NTOT1'
+         CALL LCMGET(KPMICR,'NTOT1',GAR(1,4+NL))
+      ENDIF
+      CALL LCMLEN(KPMICR,'NUSIGF',LENGTH,ITYLCM)
+      IF(LENGTH.EQ.NGCOND) THEN
+         CALL LCMGET(KPMICR,'NUSIGF',GAR(1,5+NL))
+         HMAKE(5+NL)='NUSIGF'
+      ENDIF
+      IF(NDEL.GT.0) THEN
+         WRITE(TEXT12,'(6HNUSIGF,I2.2)') NDEL
+         CALL LCMLEN(KPMICR,TEXT12,LENGTH,ITYLCM)
+         IF(LENGTH.EQ.NGCOND) THEN
+            DO 40 IDEL=1,NDEL
+            WRITE(TEXT12,'(6HNUSIGF,I2.2)') IDEL
+            CALL LCMGET(KPMICR,TEXT12,GAR(1,MAXH-2*NDEL-2+IDEL))
+            HMAKE(MAXH-2*NDEL-2+IDEL)=TEXT12
+   40       CONTINUE
+         ENDIF
+      ENDIF
+      CALL LCMLEN(KPMICR,'H-FACTOR',LENGTH,ITYLCM)
+      IF(LENGTH.EQ.NGCOND) THEN
+         CALL LCMGET(KPMICR,'H-FACTOR',GAR(1,MAXH-2*NDEL-4))
+         HMAKE(MAXH-2*NDEL-4)='H-FACTOR'
+      ENDIF
+      CALL LCMLEN(KPMICR,'OVERV',LENGTH,ITYLCM)
+      IF(LENGTH.EQ.NGCOND) THEN
+         CALL LCMGET(KPMICR,'OVERV',GAR(1,MAXH-2*NDEL-3))
+         HMAKE(MAXH-2*NDEL-3)='OVERV'
+      ENDIF
+      CALL LCMLEN(KPMICR,'TRANC',LENGTH,ITYLCM)
+      IF(LENGTH.EQ.NGCOND) THEN
+         CALL LCMGET(KPMICR,'TRANC',GAR(1,MAXH-2*NDEL-2))
+         HMAKE(MAXH-2*NDEL-2)='TRANC'
+      ENDIF
+      DO 60 IED=1,NED
+      WRITE(TEXT8,'(2A4)') (IHEDIT(I0,IED),I0=1,2)
+      CALL LCMLEN(KPMICR,TEXT8,LENGTH,ITYLCM)
+      IF((LENGTH.GT.0).AND.(TEXT8.NE.'TRANC')) THEN
+         CALL LCMGET(KPMICR,TEXT8,GAR(1,5+NL+IED))
+         HMAKE(5+NL+IED)=TEXT8
+      ENDIF
+   60 CONTINUE
+      CALL LCMLEN(KPMICR,'STRD',LENGTH,ITYLCM)
+      IF(LENGTH.EQ.NGCOND) THEN
+         CALL LCMGET(KPMICR,'STRD',GAR(1,MAXH))
+         HMAKE(MAXH)='STRD'
+      ENDIF
+*----
+*  APPLY SPH CORRECTION
+*----
+      DO 80 J=1,MAXH
+      IF((HMAKE(J).NE.' ').AND.(HMAKE(J)(:4).NE.'SIGS')) THEN
+         DO 70 IG=1,NGCOND
+         IF((HMAKE(J)(:4).EQ.'STRD').OR.(HMAKE(J).EQ.'NWT0').OR.
+     >           (HMAKE(J).EQ.'TRANC')) THEN
+            GAR(IG,J)=GAR(IG,J)/SPH(IBM,IG)
+         ELSE IF(HMAKE(J)(:5).EQ.'NWT1') THEN
+            CONTINUE
+         ELSE IF(HMAKE(J)(:4).EQ.'NTOT') THEN
+            CONTINUE
+         ELSE
+            GAR(IG,J)=GAR(IG,J)*SPH(IBM,IG)
+         ENDIF
+   70    CONTINUE
+      ENDIF
+   80 CONTINUE
+      DO 105 IL=1,NL
+      ITYPR(IL)=0
+      IF(HMAKE(MAXH+IL+1).NE.' ') ITYPR(IL)=1
+      DO 100 IG2=1,NGCOND
+      DSUM=0.0
+      DO 90 IG1=1,NGCOND
+      IF(MOD(IL-1,2).EQ.0) THEN
+         IF(IG1.EQ.IG2) THEN
+           WSCAT(IG1,IG1,IL)=WSCAT(IG1,IG1,IL)*SPH(IBM,IG1)
+     >     +GAR(IG1,3+NL)*(1.0-SPH(IBM,IG1))
+         ELSE
+           WSCAT(IG1,IG2,IL)=WSCAT(IG1,IG2,IL)*SPH(IBM,IG2) ! IG1 <- IG2
+         ENDIF
+      ELSE
+         IF(IG1.EQ.IG2) THEN
+           WSCAT(IG1,IG1,IL)=WSCAT(IG1,IG1,IL)/SPH(IBM,IG1)
+     >     +GAR(IG1,4+NL)*(1.0-1.0/SPH(IBM,IG1))
+         ELSE
+           WSCAT(IG1,IG2,IL)=WSCAT(IG1,IG2,IL)/SPH(IBM,IG1)
+         ENDIF
+      ENDIF
+      DSUM=DSUM+WSCAT(IG1,IG2,IL)
+   90 CONTINUE
+      IF(IL.EQ.1) THEN
+         GAR(IG2,2+IL)=GAR(IG2,2+IL)*SPH(IBM,IG2)+GAR(IG2,3+NL)*
+     1   (1.0-SPH(IBM,IG2))
+      ELSE
+         GAR(IG2,2+IL)=REAL(DSUM)
+      ENDIF
+  100 CONTINUE
+  105 CONTINUE
+*----
+*  SAVE CORRECTED INFORMATION ON LCM
+*----
+      DO 110 J=1,MAXH
+      IF((HMAKE(J).NE.' ').AND.(HMAKE(J)(:4).NE.'SIGS')) THEN
+         CALL LCMPUT(KPMICR,HMAKE(J),NGCOND,2,GAR(1,J))
+      ENDIF
+  110 CONTINUE
+      CALL XDRLGS(KPMICR,1,IPRINT,0,NL-1,1,NGCOND,GAR(1,3),WSCAT,ITYPR)
+  200 CONTINUE
+      IF(IPRINT.GT.2) WRITE(6,'(/28H TONCMI: MICROLIB CORRECTED.)')
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(IPISO,IMIX,IHUSED)
+      DEALLOCATE(WSCAT,GAR)
+      DEALLOCATE(ITYPR,IHEDIT)
+      RETURN
+      END