diff options
Diffstat (limited to 'Dragon/src/LDRGEO.f')
| -rw-r--r-- | Dragon/src/LDRGEO.f | 179 |
1 files changed, 179 insertions, 0 deletions
diff --git a/Dragon/src/LDRGEO.f b/Dragon/src/LDRGEO.f new file mode 100644 index 0000000..d61795a --- /dev/null +++ b/Dragon/src/LDRGEO.f @@ -0,0 +1,179 @@ +*DECK LDRGEO + LOGICAL FUNCTION LDRGEO(IPGEOM,GEON1,GEON2,IMPX) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Compare two sub-geometries stored on LCM (do not compare mixture +* numbers). +* +*Copyright: +* Copyright (C) 1002 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 +* IPGEOM pointer to the geometry (L_GEOM signature). +* GEON1 name of the first sub-geometry. +* GEON2 name of the second sub-geometry. +* IMPX print flag (impx=0 for no print). +* +*Parameters: output +* LDRGEO equality flag (=.true. if the two geometries are identical). +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + TYPE(C_PTR) IPGEOM + INTEGER IMPX + CHARACTER GEON1*12,GEON2*12 +*---- +* LOCAL VARIABLES +*---- + PARAMETER (MAXLEV=50) + TYPE(C_PTR) IPLIS1,IPLIS2,KDATA1(MAXLEV),KDATA2(MAXLEV) + CHARACTER NAMT*12,GEON3*12,GEON4*12,HNAME*12,NAMMY1*12,NAMMY2*12, + 1 CTMP1*4,CTMP2*4,PATH(MAXLEV)*12,FIRST(MAXLEV)*12,HSMG*131 + INTEGER IGO(MAXLEV) + LOGICAL EMPTY,LCM + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA1,IDATA2 + REAL, ALLOCATABLE, DIMENSION(:) :: RDATA1,RDATA2 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DDATA1,DDATA2 +* + CALL LCMLEN(IPGEOM,GEON1,ILON1,ITY1) + IF(ILON1.EQ.0) CALL XABORT('LDRGEO: UNKNOWN GEOMETRY (1).') + CALL LCMLEN(IPGEOM,GEON1,ILON1,ITY1) + IF(ILON1.EQ.0) CALL XABORT('LDRGEO: UNKNOWN GEOMETRY (2).') + GEON3=GEON1 + GEON4=GEON2 + DO 120 IORDER=1,2 + IPLIS1=LCMGID(IPGEOM,GEON3) + IPLIS2=LCMGID(IPGEOM,GEON4) + LDRGEO=.TRUE. + ILEV=1 + KDATA1(1)=IPLIS1 + KDATA2(1)=IPLIS2 + IGO(1)=3 +* +* ASSOCIATIVE TABLE. + 10 CALL LCMINF(IPLIS1,HNAME,NAMMY1,EMPTY,ILONG,LCM) + CALL LCMINF(IPLIS2,HNAME,NAMMY2,EMPTY,ILONG,LCM) + IF(EMPTY) GO TO (100,100,110),IGO(ILEV) + NAMT=' ' + CALL LCMNXT(IPLIS1,NAMT) +* + FIRST(ILEV)=NAMT + 20 CALL LCMLEN(IPLIS1,NAMT,ILON1,ITY1) + CALL LCMLEN(IPLIS2,NAMT,ILON2,ITY2) + IF((ILON1.NE.ILON2).OR.(ITY1.NE.ITY2)) THEN + LDRGEO=.FALSE. + IF(IMPX.GT.0) WRITE (6,130) GEON3,GEON4,NAMT + RETURN + ENDIF + IF(ITY1.EQ.0) THEN +* ASSOCIATIVE TABLE DATA. + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) THEN + WRITE(HSMG,'(2A,A12,A)') 'LDRGEO: TOO MANY DIRECTORY ', + 1 'LEVELS ON ''',HNAME,'''.' + CALL XABORT(HSMG) + ENDIF + KDATA1(ILEV)=LCMGID(IPLIS1,NAMT) + KDATA2(ILEV)=LCMGID(IPLIS2,NAMT) + PATH(ILEV)=NAMT + IPLIS1=KDATA1(ILEV) + IPLIS2=KDATA2(ILEV) + IGO(ILEV)=1 + GO TO 10 + ELSE IF(ITY1.LE.6) THEN + IF(ITY1.EQ.1) THEN +* INTEGER DATA. + ALLOCATE(IDATA1(ILON1),IDATA2(ILON2)) + CALL LCMGET(IPLIS1,NAMT,IDATA1) + CALL LCMGET(IPLIS2,NAMT,IDATA2) + IF((NAMT.NE.'MIX').AND.(NAMT.NE.'STATE-VECTOR')) THEN + DO 40 I=1,ILON1 + LDRGEO=LDRGEO.AND.(IDATA1(I).EQ.IDATA2(I)) + 40 CONTINUE + ELSE IF(NAMT.EQ.'STATE-VECTOR') THEN + DO 50 I=1,6 + LDRGEO=LDRGEO.AND.(IDATA1(I).EQ.IDATA2(I)) + 50 CONTINUE + ENDIF + DEALLOCATE(IDATA2,IDATA1) + ELSE IF(ITY1.EQ.2) THEN +* SINGLE PRECISION DATA. + ALLOCATE(RDATA1(ILON1),RDATA2(ILON2)) + CALL LCMGET(IPLIS1,NAMT,RDATA1) + CALL LCMGET(IPLIS2,NAMT,RDATA2) + ZMAX=0.0 + DO 60 I=1,ILON1 + ZMAX=MAX(ZMAX,ABS(RDATA1(I)),ABS(RDATA2(I))) + 60 CONTINUE + IF(ZMAX.EQ.0.0) ZMAX=1.0 + DO 70 I=1,ILON1 + EPS=ABS(RDATA1(I)-RDATA2(I))/ZMAX + LDRGEO=LDRGEO.AND.(EPS.LT.1.0E-4) + 70 CONTINUE + DEALLOCATE(RDATA2,RDATA1) + ELSE IF(ITY1.EQ.3) THEN +* CHARACTER*4 DATA. + ALLOCATE(IDATA1(ILON1),IDATA2(ILON2)) + CALL LCMGET(IPLIS1,NAMT,IDATA1) + CALL LCMGET(IPLIS2,NAMT,IDATA2) + DO 80 I=1,ILON1 + WRITE(CTMP1,'(A4)') IDATA1(I) + WRITE(CTMP2,'(A4)') IDATA2(I) + LDRGEO=LDRGEO.AND.(CTMP1.EQ.CTMP2) + 80 CONTINUE + DEALLOCATE(IDATA2,IDATA1) + ELSE IF(ITY1.EQ.4) THEN +* DOUBLE PRECISION DATA. + ALLOCATE(DDATA1(ILON1),DDATA2(ILON2)) + CALL LCMGET(IPLIS1,NAMT,DDATA1) + CALL LCMGET(IPLIS2,NAMT,DDATA2) + ZMAX=0.0 + DO 85 I=1,ILON1 + ZMAX=MAX(ZMAX,REAL(ABS(DDATA1(I))),REAL(ABS(DDATA2(I)))) + 85 CONTINUE + IF(ZMAX.EQ.0.0) ZMAX=1.0 + DO 90 I=1,ILON1 + EPS=ABS(REAL(DDATA1(I)-DDATA2(I)))/ZMAX + LDRGEO=LDRGEO.AND.(EPS.LT.1.0E-4) + 90 CONTINUE + DEALLOCATE(DDATA2,DDATA1) + ELSE + CALL XABORT('LDRGEO: INVALID DATA TYPE.') + ENDIF + IF(.NOT.LDRGEO) THEN + LDRGEO=.FALSE. + IF(IMPX.GT.0) WRITE (6,130) GEON3,GEON4,NAMT + RETURN + ENDIF + ENDIF + CALL LCMNXT(IPLIS1,NAMT) + IF(NAMT.NE.FIRST(ILEV)) GO TO 20 + GO TO (100,100,110),IGO(ILEV) +* + 100 NAMT=PATH(ILEV) + ILEV=ILEV-1 + IPLIS1=KDATA1(ILEV) + IPLIS2=KDATA2(ILEV) + CALL LCMNXT(IPLIS1,NAMT) + IF(NAMT.NE.FIRST(ILEV)) GO TO 20 + GO TO (100,100,110),IGO(ILEV) + 110 GEON3=GEON2 + GEON4=GEON1 + 120 CONTINUE + RETURN +* + 130 FORMAT (/34H LDRGEO: COMPARISON OF GEOMETRIES ,A12,5H AND ,A12, + 1 16H --- LCM BLOCK ',A12,15H' IS DIFFERENT.) + END |