Initial commit from Polytechnique Montreal

1 files changed, 135 insertions, 0 deletions

diff --git a/Donjon/src/SIMQMP.f b/Donjon/src/SIMQMP.f
new file mode 100644
index 0000000..9143a89
--- /dev/null
+++ b/Donjon/src/SIMQMP.f
@@ -0,0 +1,135 @@
+*DECK SIMQMP
+      SUBROUTINE SIMQMP(LX,LY,LXMIN,LYMIN,HHX,IHY,CYCLE)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Unfold the quarter shuffling map to full shuffling map, using
+* rotations around the center.
+*
+*Copyright:
+* Copyright (C) 2013 Ecole Polytechnique de Montreal
+*
+*Author(s): 
+* V. Salino
+*
+*Parameters: input
+* LX      number of assemblies along the X axis.
+* LY      number of assemblies along the Y axis.
+* LXMIN   coordinates on X axis of the first assembly.
+* LYMIN   coordinates on Y axis of the first assembly.
+* HHX     naval battle indices along X axis.
+* IHY     naval battle indices along Y axis.
+*
+*Parameters: input/output
+* CYCLE   shuffling matrix for refuelling given as a quarter map,
+*         and returned as a full reconstructed matrix
+*
+*-----------------------------------------------------------------------
+*
+*----
+*  SUBROUTINE ARGUMENTS
+*----
+      INTEGER LX,LY,LXMIN,LYMIN,IHY(LY)
+      CHARACTER HHX(LX)*1,CYCLE(LX,LY)*4
+*----
+*  LOCAL VARIABLES
+*   ROTMAT  counter-clockwise rotation matrices, with an Y-axis directed
+*           downward.
+*           ROTMAT(x,x,1) <  90 degrees rotation matrix
+*           ROTMAT(x,x,2) < 180 degrees rotation matrix
+*           ROTMAT(x,x,3) < 270 degrees rotation matrix
+*----
+      INTEGER INTG2,XPOS,YPOS,Q
+      REAL XCENTER,YCENTER,ROTX(3),ROTY(3),IROT(3),JROT(3),
+     >     ROTMAT(2,2,3)
+      CHARACTER TEXT4*4,TEXT1*1,RECONS(3)*4
+*
+      DATA ROTMAT(1,1,1), ROTMAT(1,2,1)/+0.0, +1.0/
+      DATA ROTMAT(2,1,1), ROTMAT(2,2,1)/-1.0, +0.0/
+*
+      DATA ROTMAT(1,1,2), ROTMAT(1,2,2)/-1.0, +0.0/
+      DATA ROTMAT(2,1,2), ROTMAT(2,2,2)/+0.0, -1.0/
+*
+      DATA ROTMAT(1,1,3), ROTMAT(1,2,3)/+0.0, -1.0/
+      DATA ROTMAT(2,1,3), ROTMAT(2,2,3)/+1.0, +0.0/
+*
+      IF(LX.NE.LY) CALL XABORT('@SIMQMP: QMAP KEYWORD IS NOT
+     > COMPATIBLE WITH A NON-SQUARE REFUELLING SCHEME.')
+      XCENTER=(REAL(LX)+1)/2
+      YCENTER=(REAL(LY)+1)/2
+      DO J=LYMIN,LY
+        DO I=LXMIN,LX
+*         Excluding potential central assembly from reconstruction
+          IF(.NOT.(MOD(LX,2).EQ.1.AND.I.EQ.LXMIN.AND.J.EQ.LYMIN)) THEN
+            TEXT4=CYCLE(I,J)
+            DO Q=1,3
+              IF((TEXT4.NE.'NEW').AND.(TEXT4.NE.'|').AND.(TEXT4.NE.'-')
+     >        .AND.(TEXT4.NE.'-|-').AND.(TEXT4.NE.'SPC').AND.
+     >        (TEXT4(4:).NE.'@')) THEN
+                READ(TEXT4,'(A1,I2)') TEXT1,INTG2
+                XPOS=0
+                DO K=1,LX
+                  IF(HHX(K).EQ.TEXT1) THEN
+                    IF(XPOS.NE.0)CALL XABORT('@SIMQMP: X-AXIS HAS '
+     >              //'MULTIPLE TIMES THE SAME COORDINATES. CHECK '
+     >              //'YOUR RESINI: CALL.')
+                    XPOS=K
+                  ENDIF
+                ENDDO
+                IF(XPOS.EQ.0) CALL XABORT('@SIMQMP: UNABLE TO FIND XPO'
+     >          //'S(1).')
+                YPOS=0
+                DO K=1,LY
+                  IF(IHY(K).EQ.INTG2) THEN
+                    IF(YPOS.NE.0)CALL XABORT('@SIMQMP: Y-AXIS HAS '
+     >              //'MULTIPLE TIMES THE SAME COORDINATES. CHECK '
+     >              //'YOUR RESINI: CALL.')
+                    YPOS=K
+                  ENDIF
+                ENDDO
+                IF(YPOS.EQ.0) CALL XABORT('@SIMQMP: UNABLE TO FIND YPO'
+     >          //'S(2).')
+*               Reconstruction of an element of the matrix
+                ROTX(Q)=ROTMAT(1,1,Q)*(REAL(XPOS)-XCENTER)
+     >                 +ROTMAT(1,2,Q)*(REAL(YPOS)-YCENTER)+XCENTER
+                ROTY(Q)=ROTMAT(2,1,Q)*(REAL(XPOS)-XCENTER)
+     >                 +ROTMAT(2,2,Q)*(REAL(YPOS)-YCENTER)+YCENTER
+                WRITE(RECONS(Q),'(A1,I2.2)') HHX(INT(ROTX(Q))),
+     >                                       IHY(INT(ROTY(Q)))
+              ELSE
+                RECONS(Q)=TEXT4
+              ENDIF
+*             Coordinates of the assembly to be filled with
+*             reconstructed information
+              IROT(Q)=ROTMAT(1,1,Q)*(REAL(I)-XCENTER)
+     >               +ROTMAT(1,2,Q)*(REAL(J)-YCENTER)+XCENTER
+              JROT(Q)=ROTMAT(2,1,Q)*(REAL(I)-XCENTER)
+     >               +ROTMAT(2,2,Q)*(REAL(J)-YCENTER)+YCENTER
+            ENDDO
+*         
+            IF((J.EQ.LYMIN).AND.(MOD(LX,2).EQ.1)) THEN
+              IF(RECONS(3).NE.CYCLE(INT(IROT(3)),INT(JROT(3)))) THEN
+                WRITE(6,10)
+                WRITE(6,20) HHX(I),IHY(J),CYCLE(I,J),RECONS(3),
+     >          HHX(INT(IROT(3))),IHY(INT(JROT(3))),
+     >          CYCLE(INT(IROT(3)),INT(JROT(3)))
+                CALL XABORT('@SIMQMP: CHECK FOR AN ERROR IN THE QUARTE'
+     >          //'R-MAP RELOADING PATTERN OR SWITCH TO MAP KEYWORD.')
+              ENDIF
+            ENDIF
+*         
+            DO Q=1,3
+              CYCLE(INT(IROT(Q)),INT(JROT(Q)))=RECONS(Q)
+            ENDDO
+          ENDIF
+        ENDDO
+      ENDDO
+      RETURN
+*
+  10  FORMAT('@SIMQMP: INCONSISTENCY IN REDUNDANT DATA. THE ',
+     > 'QUARTER-MAP RELOADING PATTERN IS NOT QUARTER-SYMETRIC.')
+  20  FORMAT('CONTENT OF ',A1,I2.2,' (',A4,') IS SUPPOSED TO LEAD TO "'
+     > ,A4,'" IN ',A1,I2.2,', BUT "',A4,'" HAS BEEN SPECIFIED ',
+     > 'INSTEAD.')
+      END