Initial commit from Polytechnique Montreal

1 files changed, 274 insertions, 0 deletions

diff --git a/Donjon/src/TINSHU.f b/Donjon/src/TINSHU.f
new file mode 100644
index 0000000..9c31b9b
--- /dev/null
+++ b/Donjon/src/TINSHU.f
@@ -0,0 +1,274 @@
+*DECK TINSHU
+      SUBROUTINE TINSHU(IPRES,NCH,NK,NX,NY,NZ,NREG,MS,NAMCHA,NAMCH2,
+     + WINT,MIX,BS,PS,ISFT,IXN,IYN,IPRT)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Compute new burnup values per channel after shuffling of two
+* channels
+*
+*Copyright:
+* Copyright (C) 2010 Ecole Polytechnique de Montreal
+*
+*Author(s): 
+* E. Varin, M. Guyot
+*
+*Parameters: input/output
+* IPRES  Adress of the map Linked_List or XSM file.
+* NAMCHA Name of the channel to refuel
+* NAMCH2 Name of the channel to refuel
+* NS     Number of bundles inserted
+* MIX    Fuel map bundle index
+* MS     Maximum number of power shift
+*
+*Parameters: 
+* NCH       
+* NK        
+* NX        
+* NY        
+* NZ        
+* NREG      
+* WINT      
+* BS        
+* PS        
+* ISFT      
+* IXN       
+* IYN       
+* IPRT
+*
+*-----------------------------------------------------------------------
+*
+      USE GANLIB
+      IMPLICIT NONE
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      TYPE(C_PTR) IPRES
+      INTEGER     NCH,NK,NX,NY,NZ,NREG,ILONG,ITYP,IX,IY,IPRT,
+     1            ICH1,ICH2,ILS,ITYLCM,IS,MAXS,MS
+      REAL        WINT(NCH,NK),BS(NCH,NK,MS),PS(NCH,NK,MS)
+      CHARACTER   XNAM*4,YNAM*4,NAMCHA*4,NAMCH2*4,TEXT4*4,CS*2
+      INTEGER     MIX(NREG),IXN(NX),IYN(NY),ISFT(NCH,NK)
+*----
+*  LOCAL VARIABLES
+*----
+      INTEGER ICH,IEL,I,J,IZ
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ICHMAP
+      INTEGER, ALLOCATABLE, DIMENSION(:,:) :: INDEX
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: POOL
+      CHARACTER HSMG*131
+*----
+*  SCRATCH STORAGE ALLOCATION
+*----
+      ALLOCATE(ICHMAP(NX,NY),INDEX(NCH,NK),POOL(NCH,NK))
+*----
+*  RECOVER INFORMATIONS FROM FUEL MAP OBJECT
+*----
+      DO 1 I=1,NK
+       DO 2 J=1,NCH
+         WINT(J,I) = 0.0
+         ISFT(J,I) = 0
+         POOL(J,I) = 0.0
+         DO 3 IS=1,MS
+           BS(J,I,IS)=0.0
+           PS(J,I,IS)=0.0
+  3      CONTINUE
+  2   CONTINUE
+  1   CONTINUE
+*----
+*  RECOVER FUEL BURNUPS
+*----
+      CALL LCMLEN(IPRES,'BURN-INST',ILONG,ITYP)
+      IF(ILONG.EQ.0) THEN
+         CALL XABORT('@TINSHU: INITIAL BURNUP REQUIRED')
+      ENDIF
+      CALL LCMGET(IPRES,'BURN-INST',WINT(1,1))
+*----
+*  RECOVER FUEL INDEX
+*----
+      CALL LCMLEN(IPRES,'FLMIX',ILONG,ITYP)
+      IF(ILONG.NE.0) THEN
+         CALL LCMGET(IPRES,'FLMIX',INDEX)
+      ELSE
+         CALL XABORT('@TINSHU: FLMIX ARE REQUIRED')
+      ENDIF
+*----
+*  RECOVER SHIFT VECTOR
+*----
+      MAXS=0
+      CALL LCMLEN(IPRES,'ISHIFT',ILS,ITYLCM)
+      IF(ILS.NE.0) THEN
+        CALL LCMGET(IPRES,'ISHIFT',ISFT(1,1))
+        DO 16 I=1,NK
+         DO 15 J=1,NCH
+            MAXS=MAX(MAXS,ISFT(J,I))
+ 15     CONTINUE
+ 16     CONTINUE
+      ELSE
+        MAXS=0
+      ENDIF
+
+      IF(MAXS.GT.0) THEN
+        DO 17 IS=1,MAXS
+          WRITE (CS,'(I2)') IS
+          CALL LCMGET(IPRES,'BSHIFT'//CS,BS(1,1,IS))
+          CALL LCMGET(IPRES,'PSHIFT'//CS,PS(1,1,IS))
+ 17     CONTINUE
+      ENDIF
+*----
+*  SET THE CHANNEL INDEX MAP
+*----
+      CALL LCMSIX(IPRES,' ',0)
+      CALL LCMGET(IPRES,'BMIX',MIX)
+      ICHMAP(:NX,:NY)=0
+      ICH=0
+      DO 26 IY=1,NY
+      DO 25 IX=1,NX
+      IEL=(IY-1)*NX+IX
+      DO 23 IZ=1,NZ
+      IF(MIX((IZ-1)*NX*NY+IEL).NE.0) GO TO 24
+  23  CONTINUE
+      GO TO 25
+  24  ICH=ICH+1
+      ICHMAP(IX,IY)=ICH
+  25  CONTINUE
+  26  CONTINUE
+      IF(ICH.NE.NCH) CALL XABORT('@TINSHU: INVALID NUMBER OF CHANNELS')
+*----
+*  SEARCH FOR CHANNEL NUMBER TO MOVE
+*----
+      TEXT4 = NAMCHA(2:3)
+      IX = 0
+      IY = 0
+      DO 10 I=1,NX
+        WRITE(XNAM,'(A4)') IXN(I)
+        IF (XNAM.EQ.TEXT4) THEN
+           IX = I
+           GOTO 11
+        ENDIF
+  10  CONTINUE
+      WRITE(HSMG,'(26H@TINSHU: NO CHANNEL NAMED ,A4,12H IN FUELMAP.)')
+     + NAMCHA
+      CALL XABORT(HSMG)
+  11  TEXT4 = NAMCHA(1:1)
+      DO 20 I=1,NY
+        WRITE(YNAM,'(A4)') IYN(I)
+        IF (YNAM.EQ.TEXT4) THEN
+           IY = I
+           GOTO 21
+        ENDIF
+  20  CONTINUE
+      WRITE(HSMG,'(26H@TINSHU: NO CHANNEL NAMED ,A4,12H IN FUELMAP.)')
+     + NAMCHA
+      CALL XABORT(HSMG)
+
+  21  ICH1 = ICHMAP(IX,IY)
+      IF(ICH1.EQ.0) THEN
+        WRITE(6,'(13H @TINSHU: IX=,I6,4H IY=,I6)') IX,IY
+        WRITE(HSMG,'(23H@TINREF: CHANNEL NAMED ,A4,13H HAS NO FUEL.)')
+     +  NAMCHA
+        CALL XABORT(HSMG)
+      ENDIF
+      IF(IPRT.GT.3) THEN
+        WRITE(6,*)
+        WRITE(6,*) ' SHUFFLING CHANNEL ',NAMCHA,ICH1
+        WRITE(6,*) ' BEFORE ',NAMCHA,(WINT(ICH1,I),I=1,NK)
+      ENDIF
+*----
+*  SEARCH FOR CHANNEL NUMBER WHERE TO MOVE
+*----
+      IF(NAMCH2.NE.'POOL') THEN
+        TEXT4 = NAMCH2(2:3)
+        IX = 1
+        IY = 1
+        DO 30 I=1,NX
+          WRITE(XNAM,'(A4)') IXN(I)
+          IF (XNAM.EQ.TEXT4) THEN
+             IX = I
+             GOTO 31
+          ENDIF
+  30    CONTINUE
+        WRITE(HSMG,'(26H@TINSHU: NO CHANNEL NAMED ,A4,12H IN FUELMAP.)')
+     +  NAMCHA
+        CALL XABORT(HSMG)
+  31    TEXT4 = NAMCH2(1:1)
+        DO 40 I=1,NY
+          WRITE(YNAM,'(A4)') IYN(I)
+          IF (YNAM.EQ.TEXT4) THEN
+             IY = I
+             GOTO 41
+          ENDIF
+  40    CONTINUE
+        WRITE(HSMG,'(26H@TINSHU: NO CHANNEL NAMED ,A4,12H IN FUELMAP.)')
+     +  NAMCHA
+        CALL XABORT(HSMG)
+
+  41    ICH2 = ICHMAP(IX,IY)
+        IF(ICH2.EQ.0) CALL XABORT('@TINSHU: WRONG CHANNEL NAME')
+        IF(IPRT.GT.3) THEN
+          WRITE(6,*)
+          WRITE(6,*) ' SHUFFLING CHANNEL ',NAMCH2,ICH2
+          WRITE(6,*) ' BEFORE ',NAMCH2,(WINT(ICH2,I),I=1,NK)
+        ENDIF
+*----
+*  SHUFFLING
+*----
+        DO 50 I=1,NK
+          IF(WINT(ICH2,I).NE.0.0) THEN
+             WRITE(6,*) ' BURNUP ',WINT(ICH2,I)
+             CALL XABORT('@TINSHU: WRONG POSITION TO SHUFFLE, '
+     +          //'CHANNEL NOT EMPTY')
+          ENDIF
+          WINT(ICH2,I) = WINT(ICH1,I)
+          WINT(ICH1,I) = 0.0
+          ISFT(ICH2,I) = ISFT(ICH1,I)
+          ISFT(ICH1,I) = 0
+          INDEX(ICH2,I) = INDEX(ICH1,I)
+          IF(MAXS.GT.0) THEN
+             DO 56 IS=1,MAXS
+               BS(ICH2,I,IS) = BS(ICH1,I,IS)
+               PS(ICH2,I,IS) = PS(ICH1,I,IS)
+               BS(ICH1,I,IS) = 0.0
+               PS(ICH1,I,IS) = 0.0
+  56         CONTINUE
+          ENDIF
+  50    CONTINUE
+        IF(IPRT.GT.3) THEN
+          WRITE(6,*)
+          WRITE(6,*) ' AFTER ',NAMCH2,(WINT(ICH2,I),I=1,NK)
+        ENDIF
+      ELSE
+        WRITE(6,*) ' CHANNEL TO POOL '
+*----
+*  RECOVER DISCHARGED FUEL BURNUPS
+*----
+        CALL LCMLEN(IPRES,'BURN-POOL',ILONG,ITYP)
+        IF(ILONG.NE.0) THEN
+           CALL LCMGET(IPRES,'BURN-POOL',POOL(1,1))
+        ENDIF
+        DO 51 I=1,NK
+          POOL(ICH1,I) = WINT(ICH1,I)
+          WINT(ICH1,I) = 0.0
+  51    CONTINUE
+        CALL LCMPUT(IPRES,'BURN-POOL',NCH*NK,2,POOL(1,1))
+      ENDIF
+      IF(IPRT.GT.3)
+     +    WRITE(6,*) ' AFTER ',NAMCHA,(WINT(ICH1,I),I=1,NK)
+      CALL LCMSIX(IPRES,' ',0)
+      CALL LCMPUT(IPRES,'BURN-INST',NCH*NK,2,WINT(1,1))
+      CALL LCMPUT(IPRES,'FLMIX',NCH*NK,1,INDEX(1,1))
+      CALL LCMPUT(IPRES,'ISHIFT',NCH*NK,1,ISFT(1,1))
+      IF(MAXS.GT.0) THEN
+        DO 53 IS=1,MAXS
+          WRITE (CS,'(I2)') IS
+          CALL LCMPUT(IPRES,'BSHIFT'//CS,NCH*NK,2,BS(1,1,IS))
+          CALL LCMPUT(IPRES,'PSHIFT'//CS,NCH*NK,2,PS(1,1,IS))
+ 53     CONTINUE
+      ENDIF
+*----
+*  SCRATCH STORAGE DEALLOCATION
+*----
+      DEALLOCATE(POOL,INDEX,ICHMAP)
+      RETURN
+      END