summaryrefslogtreecommitdiff
path: root/Dragon/src/DEPLIT.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/DEPLIT.f')
-rw-r--r--Dragon/src/DEPLIT.f437
1 files changed, 437 insertions, 0 deletions
diff --git a/Dragon/src/DEPLIT.f b/Dragon/src/DEPLIT.f
new file mode 100644
index 0000000..5cd4642
--- /dev/null
+++ b/Dragon/src/DEPLIT.f
@@ -0,0 +1,437 @@
+*DECK DEPLIT
+ SUBROUTINE DEPLIT (IHEX,NH,NTH,ITAB)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Compute the index table relation subgeometries
+* to a complete geometry.
+*
+*Copyright:
+* Copyright (C) 1991 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. Benaboud
+*
+*Parameters: input
+* IHEX type of symetry:
+* =1 : s30 =2 : sa60 =3 : sb60 =4 : s90 =5 : r120
+* =6 : r180 =7 : sa180 =8 : sb180 =9 : complete.
+* NH total number of hexagons in each subgeometry.
+*
+*Parameters: output
+* NTH total number of hexagons in unfolded geometry.
+* ITAB Association table for subgeometry in unfolded geometry.
+*
+*-----------------------------------------------------------------------
+*
+ LOGICAL LPAIR
+ INTEGER NP(7),ITAB(*)
+*----
+* ALLOCATABLE ARRAYS
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: J1,J2,J3,K1,K2,K3,K4
+*
+ NC=0
+ IF (IHEX.EQ.1) THEN
+ VI = 2.* SQRT(REAL(NH)) - 1.
+ VP = SQRT(REAL(4*NH+1)) - 1.
+ IF (AINT(VI).EQ.VI) THEN
+ NC = INT(VI)
+ ELSE IF (AINT(VP).EQ.VP) THEN
+ NC = INT(VP)
+ ELSE
+ CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (1).')
+ ENDIF
+ ELSE IF (IHEX.EQ.2) THEN
+ VA = (SQRT(REAL(8*NH+1)) - 1.)/2.
+ IF (AINT(VA).EQ.VA) THEN
+ NC = INT(VA)
+ ELSE
+ CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (2).')
+ ENDIF
+ ELSE IF (IHEX.EQ.3) THEN
+ VI = SQRT(REAL(2*NH-1))
+ VP = SQRT(REAL(2*NH))
+ IF (AINT(VI).EQ.VI) THEN
+ NC = INT(VI)
+ ELSE IF (AINT(VP).EQ.VP) THEN
+ NC = INT(VP)
+ ELSE
+ CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (3).')
+ ENDIF
+ ELSE IF (IHEX.EQ.4) THEN
+ VI = SQRT(REAL((4*NH-1)/3))
+ VP = SQRT(REAL(4*NH/3))
+ IF (AINT(VI).EQ.VI) THEN
+ NC = INT(VI)
+ ELSE IF (AINT(VP).EQ.VP) THEN
+ NC = INT(VP)
+ ELSE
+ CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (4).')
+ ENDIF
+ ELSE IF (IHEX.EQ.5) THEN
+ VA = (SQRT(REAL(4*(NH-1)+1)) + 1.)/2.
+ IF (AINT(VA).EQ.VA) THEN
+ NC = INT(VA)
+ ELSE
+ CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (5).')
+ ENDIF
+ ELSE IF (IHEX.EQ.6) THEN
+ VA = (SQRT(REAL(8*(NH-1)/3+1)) + 1)/2
+ IF (AINT(VA).EQ.VA) THEN
+ NC = INT(VA)
+ ELSE
+ CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (6).')
+ ENDIF
+ ELSE IF (IHEX.EQ.7) THEN
+ VA = (SQRT(REAL(24*NH+1)) + 1.)/6.
+ IF (AINT(VA).EQ.VA) THEN
+ NC = INT(VA)
+ ELSE
+ CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (7).')
+ ENDIF
+ ELSE IF (IHEX.EQ.8) THEN
+ VI = (1.+SQRT(REAL(3*(2*NH-1)+1)))/3.
+ VP = (1.+SQRT(REAL(6*NH+1)))/3.
+ IF (AINT(VI).EQ.VI) THEN
+ NC = INT(VI)
+ ELSE IF (AINT(VP).EQ.VP) THEN
+ NC = INT(VP)
+ ELSE
+ CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (8).')
+ ENDIF
+ ELSE IF (IHEX.EQ.9) THEN
+ VA = (SQRT(REAL((4*NH-1)/3)) + 1.)/2.
+ IF (AINT(VA).EQ.VA) THEN
+ NC = INT(VA)
+ ELSE
+ CALL XABORT('DEPLIT: INVALID NUMBER OF HEXAGONS (9).')
+ ENDIF
+ ELSE
+ CALL XABORT('DEPLIT: INVALID TYPE OF SYMMETRY.')
+ ENDIF
+ NTH = 1 + 3 * NC * (NC - 1)
+ ITAB(1) = 1
+ ALLOCATE(J1(NC+2),J2(NC+2),J3(NC+2),K1(NC+2),K2(NC+2),K3(NC+2),
+ > K4(NC+2))
+ J1(1) = 1
+ J2(1) = 1
+ J3(1) = 1
+ K1(1) = 1
+ K2(1) = 1
+ K3(1) = 1
+ DO 10 L = 2,NC+1
+ J1(L) = (L-1)*6
+ J3(L) = 1+3*L*(L-1)
+ J2(L) = 1+J3(L-1)
+ 10 CONTINUE
+*
+ IF (IHEX.EQ.1) THEN
+ IL=0
+ DO 20 L = 1,NC+1,2
+ K1(L) = 1 + IL
+ K1(L+1) = 1 + IL
+ IL = IL+1
+ 20 CONTINUE
+ DO 30 L = 2,NC+1
+ K2(L) = K2(L-1) + K1(L-1)
+ 30 CONTINUE
+ IL=0
+ DO 40 L = 1,NC+1,2
+ K3(L) = K2(L) + IL
+ K3(L+1) = K2(L+1) + IL
+ IL = IL+1
+ 40 CONTINUE
+ ELSE IF (IHEX.EQ.2) THEN
+ K1(2) = 2
+ DO 50 L = 2,NC+1
+ K2(L) = K2(L-1) + L
+ K1(L+1) = K1(L) + L
+ 50 CONTINUE
+ ELSE IF (IHEX.EQ.3) THEN
+ K1(2) = 2
+ DO 60 L = 1,NC+1
+ K1(L+1) = K1(L) + L
+ 60 CONTINUE
+ IL=0
+ DO 70 L = 1,NC+1,2
+ K4(L) = 1 + IL
+ K4(L+1) = 1 + IL
+ IL = IL + 2
+ 70 CONTINUE
+ DO 80 L = 2,NC+1
+ K2(L) = K2(L-1) + K4(L-1)
+ K3(L) = K3(L-1) + K4(L)
+ 80 CONTINUE
+ ELSE IF (IHEX.EQ.4) THEN
+ IL=0
+ DO 90 L = 1,NC+1,2
+ K4(L) = L + IL
+ K4(L+1) = L + IL + 1
+ IL = IL + 1
+ 90 CONTINUE
+ DO 100 L = 2,NC+1
+ K1(L) = K1(L-1) + K4(L-1)
+ K3(L) = K3(L-1) + K4(L)
+100 CONTINUE
+ IL=0
+ DO 110 L = 1,NC+1,2
+ K2(L) = K1(L) + IL
+ K2(L+1) = K1(L+1) + IL
+ IL = IL+1
+110 CONTINUE
+ ELSE IF (IHEX.EQ.5) THEN
+ DO 120 L = 2,NC+1
+ K2(L) = 2 * (L-1)
+ K1(L) = K1(L-1) + K2(L)
+120 CONTINUE
+ ELSE IF (IHEX.EQ.6) THEN
+ DO 130 L = 2,NC+1
+ K2(L) = 3 * (L-1)
+ K1(L) = K1(L-1) + K2(L)
+130 CONTINUE
+ ELSE IF (IHEX.EQ.7) THEN
+ DO 140 L = 2,NC+1
+ K2(L) = 3 + K2(L-1)
+ K1(L) = K1(L-1) + K2(L)
+140 CONTINUE
+ ELSE IF (IHEX.EQ.8) THEN
+ IL = 1
+ IF = 1
+ DO 150 L = 2,NC+1,2
+ K2(L) = 3 * (L-1)
+ K2(L+1) = 3 * L + 1
+150 CONTINUE
+ DO 160 L = 2,NC+1
+ IL = IL + K2(L)
+ IF = IF + K2(L-1)
+ K1(L) = (IF + IL) / 2
+160 CONTINUE
+ ENDIF
+*
+ DO 300 N = 2,NTH
+*
+ I=0
+ J=0
+ DO 170 I0 = 2,NC
+ IF ((N.GE.J2(I0)).AND.(N.LE.J3(I0))) THEN
+ I=I0
+ GO TO 180
+ ENDIF
+170 CONTINUE
+ IF (I.EQ.0) CALL XABORT('DEPLIT: ALGORITHM FAILURE.')
+*
+180 DO 190 K = 1,6
+ NP(K) = J2(I) + (K - 1) * (I - 1)
+190 CONTINUE
+ NP(7) = J3(I)
+ COURS2 = REAL(I)/2.
+ LPAIR = (AINT(COURS2).EQ.COURS2)
+*
+ IF (IHEX.EQ.1) THEN
+*
+ IF (N.LE.7) THEN
+ ITAB(N) = 2
+ GO TO 300
+ ENDIF
+ DO 200 L = 1,6
+ IF ((N.GE.NP(L)).AND.(N.LT.NP(L+1))) J = L
+200 CONTINUE
+ IF (N.EQ.NP(7)) J = 6
+ IF (J.EQ.0) CALL XABORT('DEPLIT: ALGORITHM FAILURE.')
+ IC = 0
+ IF (J.EQ.6) IC = 1
+ N12 = (NP(J) + NP(J+1)+IC)/2
+ N13 = N12 + 1
+*
+ IF (N.EQ.NP(J)) THEN
+ ITAB(N) = K3(I)
+ ELSE IF (N.EQ.NP(7)) THEN
+ ITAB(N) = K3(I) - 1
+ ELSE IF ((N.GT.NP(J)).AND.(N.LT.N12)) THEN
+ ITAB(N) = K3(I) - (N - NP(J))
+ ELSE IF ((N.EQ.N12).OR.((N.EQ.N13).AND.LPAIR)) THEN
+ ITAB(N) = K2(I)
+ ELSE IF ((N.EQ.N13).AND.(.NOT.LPAIR)) THEN
+ ITAB(N) = K3(I) - (NP(J+1) + IC - N)
+ ELSE IF ((N.GT.N13).AND.(N.LT.NP(J+1))) THEN
+ ITAB(N) = K3(I) - (NP(J+1) + IC - N)
+ ENDIF
+*
+ ELSE IF (IHEX.EQ.2) THEN
+*
+ DO 210 L = 1,6,2
+ IF ((N.GE.NP(L)).AND.(N.LT.NP(L+2))) J = L
+210 CONTINUE
+ IF (N.EQ.NP(7)) J = 5
+ IF (J.EQ.0) CALL XABORT('DEPLIT: ALGORITHM FAILURE.')
+*
+ IF (N.EQ.NP(J)) THEN
+ ITAB(N) = K2(I)
+ ELSE IF (N.EQ.NP(7)) THEN
+ ITAB(N) = K2(I) - 1
+ ELSE IF ((N.GT.NP(J)).AND.(N.LT.NP(J+1))) THEN
+ ITAB(N) = K2(I) - (N - NP(J))
+ ELSE IF (N.EQ.NP(J+1)) THEN
+ ITAB(N) = K1(I)
+ ELSE IF ((N.GT.NP(J+1)).AND.(N.LT.NP(J+2))) THEN
+ ITAB(N) = K1(I) + (N - NP(J+1))
+ ENDIF
+*
+ ELSE IF (IHEX.EQ.3) THEN
+*
+ IF (N.LE.7) THEN
+ ITAB(N) = 2
+ GO TO 300
+ ENDIF
+ DO 220 L = 1,6,2
+ IF ((N.GE.NP(L)).AND.(N.LT.NP(L+2))) J = L
+220 CONTINUE
+ IF (N.EQ.NP(7)) J = 5
+ IF (J.EQ.0) CALL XABORT('DEPLIT: ALGORITHM FAILURE.')
+ IC = 0
+ IF (J.EQ.5) IC = 1
+ N12 = (NP(J) + NP(J+1))/2
+ N13 = N12 + 1
+ N14 = (NP(J+1) + NP(J+2)+IC)/2
+ N15 = N14 + 1
+*
+ IF ((N.EQ.NP(J)).OR.(N.EQ.NP(J+1))) THEN
+ ITAB(N) = K1(I)
+ ELSE IF (N.EQ.NP(7)) THEN
+ ITAB(N) = K1(I) - 1
+ ELSE IF ((N.GT.NP(J)).AND.(N.LT.N12)) THEN
+ ITAB(N) = K1(I) + (N - NP(J))
+ ELSE IF ((N.EQ.N12).OR.((N.EQ.N13).AND.LPAIR)) THEN
+ ITAB(N) = K3(I)
+ ELSE IF ((N.EQ.N13).AND.(.NOT.LPAIR)) THEN
+ ITAB(N) = K3(I) - 1
+ ELSE IF ((N.GT.N13).AND.(N.LT.NP(J+1))) THEN
+ ITAB(N) = K1(I) + (NP(J+1) - N)
+ ELSE IF ((N.GT.NP(J+1)).AND.(N.LT.N14)) THEN
+ ITAB(N) = K1(I) - (N - NP(J+1))
+ ELSE IF ((N.EQ.N14).OR.((N.EQ.N15).AND.LPAIR)) THEN
+ ITAB(N) = K2(I)
+ ELSE IF ((N.EQ.N15).AND.(.NOT.LPAIR)) THEN
+ ITAB(N) = K2(I) + 1
+ ELSE IF ((N.GT.N15).AND.(N.LT.NP(J+2))) THEN
+ ITAB(N) = K1(I) - (NP(J+2) + IC - N)
+ ENDIF
+*
+ ELSE IF (IHEX.EQ.4) THEN
+*
+ IF (N.EQ.7) THEN
+ ITAB(N) = 2
+ GO TO 300
+ ENDIF
+ DO 230 L = 1,6,3
+ IF ((N.GE.NP(L)).AND.(N.LT.NP(L+3))) J = L
+230 CONTINUE
+ IF (N.EQ.NP(7)) J = 4
+ IF (J.EQ.0) CALL XABORT('DEPLIT: ALGORITHM FAILURE.')
+ IC = 0
+ IF (J.EQ.4) IC = 1
+ N12 = (NP(J+2) + NP(J+3)+IC)/2
+ N13 = N12 + 1
+*
+ IF ((N.EQ.NP(J)).OR.(N.EQ.NP(J+2))) THEN
+ ITAB(N) = K2(I)
+ ELSE IF (N.EQ.NP(7)) THEN
+ ITAB(N) = K2(I) - 1
+ ELSE IF ((N.GT.NP(J)).AND.(N.LT.NP(J+1))) THEN
+ ITAB(N) = K2(I) + (N - NP(J))
+ ELSE IF (N.EQ.NP(J+1)) THEN
+ ITAB(N) = K3(I)
+ ELSE IF ((N.GT.NP(J+1)).AND.(N.LE.N12).AND.(N.NE.NP(J+2))) THEN
+ ITAB(N) = K2(I) - (N - NP(J+2))
+ ELSE IF ((N.EQ.N13).AND.(.NOT.LPAIR)) THEN
+ ITAB(N) = K2(I) - (NP(J+3) + IC - N)
+ ELSE IF ((N.EQ.N13).AND.LPAIR) THEN
+ ITAB(N) = K1(I)
+ ELSE IF ((N.GT.N13).AND.(N.LT.NP(J+3))) THEN
+ ITAB(N) = K2(I) - (NP(J+3) + IC - N)
+ ENDIF
+*
+ ELSE IF (IHEX.EQ.5) THEN
+*
+ IF (N.EQ.7) THEN
+ ITAB(N) = 3
+ GO TO 300
+ ELSE IF ((N.EQ.11).OR.(N.EQ.15).OR.(N.EQ.19)) THEN
+ ITAB(N) = 4
+ GO TO 300
+ ENDIF
+ DO 240 L = 1,6,2
+ IF ((N.GE.NP(L)).AND.(N.LT.NP(L+2))) J = L
+240 CONTINUE
+ IF (N.EQ.NP(7)) J = 5
+ IF (J.EQ.0) CALL XABORT('DEPLIT: ALGORITHM FAILURE.')
+ IC = 0
+ IF (J.EQ.5) IC = 1
+*
+ IF ((N.GE.NP(J)).AND.(N.LE.NP(J+1))) THEN
+ ITAB(N) = K1(I) - (NP(J+1) - N)
+ ELSE IF ((N.GT.NP(J+1)).AND.(N.LE.NP(J+2)+IC)) THEN
+ ITAB(N) = K1(I) -(2*(NP(J+2)+IC)-NP(J+1)- N)
+ ENDIF
+*
+ ELSE IF (IHEX.EQ.6) THEN
+*
+ DO 250 L = 1,6,3
+ IF ((N.GE.NP(L)).AND.(N.LT.NP(L+3))) J = L
+250 CONTINUE
+ IF (N.EQ.NP(7)) J = 4
+ IF (J.EQ.0) CALL XABORT('DEPLIT: ALGORITHM FAILURE.')
+ IC = 0
+ IF (J.EQ.4) IC = 1
+*
+ IF ((N.GE.NP(J)).AND.(N.LE.NP(J+1))) THEN
+ ITAB(N) = K1(I) - (NP(J+1) - N)
+ ELSE IF ((N.GT.NP(J+1)).AND.(N.LE.NP(J+2))) THEN
+ ITAB(N) = K1(I) - 2*(NP(J+2)-NP(J+1))-(NP(J+2)-N)
+ ELSE IF ((N.GT.NP(J+2)).AND.(N.LE.NP(J+3)+IC)) THEN
+ ITAB(N) = K1(I)-(2*(NP(J+3)+IC)-NP(J+2)-N)
+ ENDIF
+*
+ ELSE IF (IHEX.EQ.7) THEN
+*
+ IF ((N.GE.NP(1)).AND.(N.LE.NP(2))) THEN
+ ITAB(N) = K1(I) - (NP(2) - N)
+ ELSE IF ((N.GT.NP(2)).AND.(N.LE.NP(3))) THEN
+ ITAB(N) = K1(I) - (NP(3) - NP(2)) + (NP(3) - N)
+ ELSE IF ((N.GT.NP(3)).AND.(N.LE.NP(4))) THEN
+ ITAB(N) = K1(I) - (NP(4) - NP(2)) + (NP(4) - N)
+ ELSE IF ((N.GT.NP(4)).AND.(N.LE.NP(5))) THEN
+ ITAB(N) = K1(I) - (NP(5) - NP(2)) + (NP(5) - N)
+ ELSE IF ((N.GT.NP(5)).AND.(N.LE.NP(6))) THEN
+ ITAB(N) = K1(I) - (NP(4) - NP(2)) - (NP(6) - N)
+ ELSE IF ((N.GT.NP(6)).AND.(N.LE.NP(7)+1)) THEN
+ ITAB(N) = K1(I) - (NP(3) - NP(2)) - (NP(7) + 1 - N)
+ ENDIF
+*
+ ELSE IF (IHEX.EQ.8) THEN
+*
+ N12 = (NP(3) + NP(4)) / 2
+ N13 = (NP(6) + NP(7) + 1) / 2
+*
+ IF ((N.GE.NP(1)).AND.(N.LE.N12)) THEN
+ ITAB(N) = K1(I) - (NP(2) - N)
+ ELSE IF ((N.GT.N12).AND.(N.LE.N13)) THEN
+ ITAB(N) = K1(I) + (NP(5) - N)
+ ELSE IF ((N.GT.N13).AND.(N.LE.NP(7)+1)) THEN
+ ITAB(N) = K1(I) - (NP(6) - NP(5)) - (NP(7) + 1 - N)
+ ENDIF
+*
+ ELSE IF (IHEX.EQ.9) THEN
+*
+ ITAB(N) = N
+*
+ ENDIF
+300 CONTINUE
+ DEALLOCATE(K4,K3,K2,K1,J3,J2,J1)
+ RETURN
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 13:22:53 +0000