summaryrefslogtreecommitdiff
path: root/Dragon/src/LDRCEL.f
diff options
context:
space:
mode:
Diffstat (limited to 'Dragon/src/LDRCEL.f')
-rw-r--r--Dragon/src/LDRCEL.f370
1 files changed, 370 insertions, 0 deletions
diff --git a/Dragon/src/LDRCEL.f b/Dragon/src/LDRCEL.f
new file mode 100644
index 0000000..6684b7c
--- /dev/null
+++ b/Dragon/src/LDRCEL.f
@@ -0,0 +1,370 @@
+*DECK LDRCEL
+ LOGICAL FUNCTION LDRCEL(IPGEOM, IT1, JT1, IT2, JT2,
+ > CELLT, NTYPES, IAXIS, NDIM, IPRT )
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Check if two cells can be connected in an assembly of cells.
+*
+*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): R. Roy
+*
+*Parameters: input
+* IPGEOM pointer to the geometry LCM object (L_GEOM signature).
+* IT1 type of the first cell.
+* JT1 turn index of the first cell.
+* IT2 type of the second cell.
+* JT2 turn index of the second cell.
+* CELLT to keep cell type names.
+* NTYPES number of types.
+* IAXIS axis of the connexion.
+* NDIM number of dimensions.
+* IPRT intermediate printing level for output.
+*
+*Parameters: output
+* LDRCEL checking flag: =.true. if cells do connect adequately;
+* =.false. if they do not connect adequately.
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+*----
+* SUBROUTINE ARGUMENTS
+*----
+ TYPE(C_PTR) IPGEOM
+ INTEGER IT1,JT1,IT2,JT2,CELLT(3*NTYPES),NTYPES,IAXIS,
+ > NDIM,IPRT
+*----
+* LOCAL VARIABLES
+*----
+ PARAMETER ( IOUT=6,NSTATE=40 )
+ INTEGER ISTAT1(NSTATE),ISTAT2(NSTATE),ILEN(3), JLEN(3)
+ CHARACTER GEOC1*12,GEOC2*12,CAXIS(3)*1,GEOCT1*18,GEOCT2*18
+ LOGICAL LDRGEO
+*----
+* ALLOCATABLE ARRAYS
+*----
+ REAL, ALLOCATABLE, DIMENSION(:) :: RIADD1,RIADD2,RIADD3,RJADD1,
+ > RJADD2,RJADD3
+*----
+* DATA STATEMENTS
+*----
+ DATA CAXIS / 'X', 'Y', 'Z' /
+*
+ IST2=0
+ IF( IAXIS.GT.NDIM )THEN
+ LDRCEL= .FALSE.
+ CALL XABORT( 'LDRCEL: # OF DIMENSIONS INCOMPATIBLE' )
+ ELSE
+ LDRCEL= .TRUE.
+ ENDIF
+ ICX1 = MOD(IAXIS , NDIM) + 1
+ ICX2 = ICX1
+ ICY1 = MOD(IAXIS+1, NDIM) + 1
+ ICY2 = ICY1
+*
+* XY-ROTATES IF NECESSARY FROM JT1 AND JT2
+ IF( JT1.EQ.2 )THEN
+ IF( ICX1.EQ.2 )THEN
+ ICX1= 1
+ ELSEIF( ICX1.EQ.1 )THEN
+ ICX1= 2
+ ENDIF
+ IF( ICY1.EQ.2 )THEN
+ ICY1= 1
+ ELSEIF( ICY1.EQ.1 )THEN
+ ICY1= 2
+ ENDIF
+ ENDIF
+ IF( JT2.EQ.2 )THEN
+ IF( ICX2.EQ.2 )THEN
+ ICX2= 1
+ ELSEIF( ICX2.EQ.1 )THEN
+ ICX2= 2
+ ENDIF
+ IF( ICY2.EQ.2 )THEN
+ ICY2= 1
+ ELSEIF( ICY2.EQ.1 )THEN
+ ICY2= 2
+ ENDIF
+ ENDIF
+ N1= 0
+ N2= 0
+ WRITE( GEOC1(1: 4),'(A4)') CELLT(3*IT1-2)
+ WRITE( GEOC1(5: 8),'(A4)') CELLT(3*IT1-1)
+ WRITE( GEOC1(9:12),'(A4)') CELLT(3*IT1 )
+ IF( IT1.NE.IT2 )THEN
+ WRITE( GEOC2(1: 4),'(A4)') CELLT(3*IT2-2 )
+ WRITE( GEOC2(5: 8),'(A4)') CELLT(3*IT2-1 )
+ WRITE( GEOC2(9:12),'(A4)') CELLT(3*IT2 )
+ IF( JT1.EQ.1 )THEN
+ GEOCT1= GEOC1//' '
+ ELSE
+ GEOCT1= GEOC1//'/TURN '
+ ENDIF
+ IF( JT2.EQ.1 )THEN
+ GEOCT2= GEOC2//' '
+ ELSE
+ GEOCT2= GEOC2//'/TURN '
+ ENDIF
+ IF( IPRT.GT.1 )THEN
+ WRITE(IOUT,'(1H ,A1,17H-CELL CONNEXION: ,2A18)')
+ > CAXIS(IAXIS), GEOCT1, GEOCT2
+ ENDIF
+ IF( .NOT.LDRGEO(IPGEOM, GEOC1, GEOC2, 0) )THEN
+*
+* ANALYSE GEOMETRIES
+ CALL LCMSIX(IPGEOM, GEOC1, 1)
+ ISTAT1(:NSTATE)=0
+ CALL LCMGET(IPGEOM, 'STATE-VECTOR', ISTAT1)
+ IST1= ISTAT1(1)
+ IF( IST1.EQ.0 ) THEN
+ CALL LCMSIX(IPGEOM, ' ', 2)
+ RETURN
+ ENDIF
+ IF( NDIM.EQ.2 )THEN
+ IF( IST1.EQ.5 .OR. IST1.EQ.20 )THEN
+ N1= 1
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICX1), ILEN(1), IT)
+ ALLOCATE(RIADD1(ILEN(1)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICX1), RIADD1)
+ ELSE
+ CALL XABORT( 'LDRCEL: ONE CELL HAS INCORRECT DIM')
+ ENDIF
+ ELSEIF( NDIM.EQ.3 )THEN
+ IF( IST1.EQ.7 .OR. IST1.EQ.21 .OR.
+ > IST1.EQ.22 .OR. IST1.EQ.23 )THEN
+ N1=2
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICX1), ILEN(1), IT)
+ ALLOCATE(RIADD1(ILEN(1)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICX1), RIADD1)
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICY1), ILEN(2), IT)
+ ALLOCATE(RIADD2(ILEN(2)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICY1), RIADD2)
+ IF( IAXIS.EQ.IST1-20 )THEN
+ N1=3
+ CALL LCMLEN(IPGEOM, 'RADIUS', ILEN(3), IT)
+ ALLOCATE(RIADD3(ILEN(3)))
+ CALL LCMGET(IPGEOM, 'RADIUS', RIADD3)
+ ENDIF
+ ELSE
+ CALL XABORT( 'LDRCEL: ONE CELL HAS INCORRECT DIM')
+ ENDIF
+ ENDIF
+ CALL LCMSIX(IPGEOM, ' ', 2)
+*
+* SCAN THE SECOND GEOMETRY
+ CALL LCMSIX(IPGEOM, GEOC2, 1)
+ ISTAT2(:NSTATE)=0
+ CALL LCMGET(IPGEOM, 'STATE-VECTOR', ISTAT2)
+ IST2= ISTAT2(1)
+ IF( IST2.EQ.0 ) THEN
+ CALL LCMSIX(IPGEOM, ' ', 2)
+ RETURN
+ ENDIF
+ IF( NDIM.EQ.2 )THEN
+ IF( IST2.EQ.5 .OR. IST2.EQ.20 )THEN
+ N2=1
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICX2), JLEN(1), IT)
+ ALLOCATE(RJADD1(JLEN(1)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICX2), RJADD1)
+ ELSE
+ CALL XABORT( 'LDRCEL: ONE CELL HAS INCORRECT DIM')
+ ENDIF
+ ELSEIF( NDIM.EQ.3 )THEN
+ IF( IST2.EQ.7 .OR. IST2.EQ.21 .OR.
+ > IST2.EQ.22 .OR. IST2.EQ.23 )THEN
+ N2=2
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICX2), JLEN(1), IT)
+ ALLOCATE(RJADD1(JLEN(1)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICX2), RJADD1)
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICY2), JLEN(2), IT)
+ ALLOCATE(RJADD2(JLEN(2)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICY2), RJADD2)
+ IF( IAXIS.EQ.IST2-20 )THEN
+ N2=3
+ CALL LCMLEN(IPGEOM, 'RADIUS', JLEN(3), IT)
+ ALLOCATE(RJADD3(JLEN(3)))
+ CALL LCMGET(IPGEOM, 'RADIUS', RJADD3)
+ ENDIF
+ ELSE
+ CALL XABORT( 'LDRCEL: ONE CELL HAS INCORRECT DIM')
+ ENDIF
+ ENDIF
+ CALL LCMSIX(IPGEOM, ' ', 2)
+ ELSE
+*
+* GEOMETRIES ARE SIMILAR, CHECK FOR XY-ROTATIONAL INVARIANCE
+ IF( JT1.NE.JT2 )THEN
+ CALL LCMSIX(IPGEOM, GEOC1, 1)
+ ISTAT1(:NSTATE)=0
+ CALL LCMGET(IPGEOM, 'STATE-VECTOR', ISTAT1)
+ IST1= ISTAT1(1)
+ IF( IST1.EQ.0 ) THEN
+ CALL LCMSIX(IPGEOM, ' ', 2)
+ RETURN
+ ENDIF
+ IF( JT1.EQ.1 )THEN
+ GEOCT1= GEOC1//' '
+ ELSE
+ GEOCT1= GEOC1//'/TURN '
+ ENDIF
+ IF( JT2.EQ.1 )THEN
+ GEOCT2= GEOC1//' '
+ ELSE
+ GEOCT2= GEOC1//'/TURN '
+ ENDIF
+ IF( IPRT.GT.1 )THEN
+ WRITE(IOUT,'(1H ,A1,17H-CELL CONNEXION: ,2A18)')
+ > CAXIS(IAXIS), GEOCT1, GEOCT2
+ ENDIF
+ IF( IST1.EQ.5 .OR. IST1.EQ.20 )THEN
+ N1= 1
+ N2= 1
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(1), ILEN(1), IT)
+ ALLOCATE(RIADD1(ILEN(1)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(1), RIADD1)
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(2), JLEN(1), IT)
+ ALLOCATE(RJADD1(JLEN(1)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(2), RJADD1)
+ ELSE IF( IST1.EQ.7 .OR. IST1.EQ.21 .OR.
+ > IST1.EQ.22 .OR. IST1.EQ.23 )THEN
+ N1=2
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICX1), ILEN(1), IT)
+ ALLOCATE(RIADD1(ILEN(1)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICX1), RIADD1)
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICY1), ILEN(2), IT)
+ ALLOCATE(RIADD2(ILEN(2)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICY1), RIADD2)
+ IF( IAXIS.EQ.IST1-20 )THEN
+ N1=3
+ CALL LCMLEN(IPGEOM, 'RADIUS', ILEN(3), IT)
+ ALLOCATE(RIADD3(ILEN(3)))
+ CALL LCMGET(IPGEOM, 'RADIUS', RIADD3)
+ ENDIF
+ N2=2
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICX2), JLEN(1), IT)
+ ALLOCATE(RJADD1(JLEN(1)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICX2), RJADD1)
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICY2), JLEN(2), IT)
+ ALLOCATE(RJADD2(JLEN(2)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICY2), RJADD2)
+ IF( IAXIS.EQ.IST2-20 )THEN
+ N2=3
+ CALL LCMLEN(IPGEOM, 'RADIUS', JLEN(3), IT)
+ ALLOCATE(RJADD3(JLEN(3)))
+ CALL LCMGET(IPGEOM, 'RADIUS', RJADD3)
+ ENDIF
+ ELSE
+ CALL XABORT( 'LDRCEL: ONE CELL HAS INCORRECT DIM')
+ ENDIF
+ CALL LCMSIX(IPGEOM, ' ', 2)
+ ENDIF
+ ENDIF
+ ELSE
+*
+* GEOMETRY ARE OF THE SAME TYPE, CHECK FOR XY-ROTATIONAL INVARIANCE
+ IF( JT1.NE.JT2 )THEN
+ CALL LCMSIX(IPGEOM, GEOC1, 1)
+ ISTAT1(:NSTATE)=0
+ CALL LCMGET(IPGEOM, 'STATE-VECTOR', ISTAT1)
+ IST1= ISTAT1(1)
+ IF( IST1.EQ.0 ) THEN
+ CALL LCMSIX(IPGEOM, ' ', 2)
+ RETURN
+ ENDIF
+ IF( JT1.EQ.1 )THEN
+ GEOCT1= GEOC1//' '
+ ELSE
+ GEOCT1= GEOC1//'/TURN '
+ ENDIF
+ IF( JT2.EQ.1 )THEN
+ GEOCT2= GEOC1//' '
+ ELSE
+ GEOCT2= GEOC1//'/TURN '
+ ENDIF
+ IF( IPRT.GT.1 )THEN
+ WRITE(IOUT,'(1H ,A1,17H-CELL CONNEXION: ,2A18)')
+ > CAXIS(IAXIS), GEOCT1, GEOCT2
+ ENDIF
+ IF( IST1.EQ.5 .OR. IST1.EQ.20 )THEN
+ N1= 1
+ N2= 1
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(1), ILEN(1), IT)
+ ALLOCATE(RIADD1(ILEN(1)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(1), RIADD1)
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(2), JLEN(1), IT)
+ ALLOCATE(RJADD1(JLEN(1)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(2), RJADD1)
+ ELSE IF( IST1.EQ.7 .OR. IST1.EQ.21 .OR.
+ > IST1.EQ.22 .OR. IST1.EQ.23 )THEN
+ N1=2
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICX1), ILEN(1), IT)
+ ALLOCATE(RIADD1(ILEN(1)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICX1), RIADD1)
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICY1), ILEN(2), IT)
+ ALLOCATE(RIADD2(ILEN(2)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICY1), RIADD2)
+ IF( IAXIS.EQ.IST1-20 )THEN
+ N1=3
+ CALL LCMLEN(IPGEOM, 'RADIUS', ILEN(3), IT)
+ ALLOCATE(RIADD3(ILEN(3)))
+ CALL LCMGET(IPGEOM, 'RADIUS', RIADD3)
+ ENDIF
+ N2=2
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICX2), JLEN(1), IT)
+ ALLOCATE(RJADD1(JLEN(1)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICX2), RJADD1)
+ CALL LCMLEN(IPGEOM, 'MESH'//CAXIS(ICY2), JLEN(2), IT)
+ ALLOCATE(RJADD2(JLEN(2)))
+ CALL LCMGET(IPGEOM, 'MESH'//CAXIS(ICY2), RJADD2)
+ IF( IAXIS.EQ.IST2-20 )THEN
+ N2=3
+ CALL LCMLEN(IPGEOM, 'RADIUS', JLEN(3), IT)
+ ALLOCATE(RJADD3(JLEN(3)))
+ CALL LCMGET(IPGEOM, 'RADIUS', RJADD3)
+ ENDIF
+ ELSE
+ CALL XABORT( 'LDRCEL: ONE CELL HAS INCORRECT DIM')
+ ENDIF
+ CALL LCMSIX(IPGEOM, ' ', 2)
+ ENDIF
+ ENDIF
+*
+* CHECK VECTORS THAT HAVE BEEN EXTRACTED AND RELEASE SPACE...
+ IF( N1.EQ.N2 )THEN
+ DO 40 I= 1, N1
+ IF( ILEN(I).NE.JLEN(I) )
+ > CALL XABORT( 'LDRCEL: INCORRECT MESHING DIM')
+ IF(I.EQ.1) THEN
+ DO 10 J= 1, ILEN(1)
+ IF( RIADD1(J).NE.RJADD1(J))
+ > CALL XABORT( 'LDRCEL: INCORRECT MESHING(1)')
+ 10 CONTINUE
+ DEALLOCATE(RJADD1,RIADD1)
+ ELSE IF(I.EQ.2) THEN
+ DO 20 J= 1, ILEN(2)
+ IF( RIADD2(J).NE.RJADD2(J))
+ > CALL XABORT( 'LDRCEL: INCORRECT MESHING(2)')
+ 20 CONTINUE
+ DEALLOCATE(RJADD2,RIADD2)
+ ELSE IF(I.EQ.3) THEN
+ DO 30 J= 1, ILEN(3)
+ IF( RIADD3(J).NE.RJADD3(J))
+ > CALL XABORT( 'LDRCEL: INCORRECT MESHING(3)')
+ 30 CONTINUE
+ DEALLOCATE(RJADD3,RIADD3)
+ ENDIF
+ 40 CONTINUE
+ ELSE
+ CALL XABORT( 'LDRCEL: TYPES ARE INCOMPATIBLE')
+ ENDIF
+ RETURN
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 11:32:46 +0000