*DECK XELETR SUBROUTINE XELETR( IPRT, NDIM, MAXGRI, NGEOME, NTOTCO, NTYPES, > NTIDL, NBLOCK, NSUR, NVOL, NTOTCL, NUNKO, > NSURO, NVOLO, MINDO, MAXDO, ICORDO, IDLDIM, > IDLGEO, KEYGEO, IDLTYP, KEYTYP, IDLBLK, KEYCYL, > RMESHO, IDLREM, INDEXO, VOLSO, MATGEO, KEYINT, > MATTYP, REMESH, MINDIM, MAXDIM, ICORD, VOLSUR, > KEYMRG, INDEX, INCELL, MATALB, NSURC, NVOLC) * *----------------------------------------------------------------------- * *Purpose: * Prepare tracking by producing the required numbering and recalculate * mesh for an exact geometry treatment. * *Copyright: * Copyright (C) 1990 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 * IPRT intermediate printing level for output. * NDIM number of dimensions (2 or 3). * MAXGRI number of blocks in X/Y/Z directions. * NGEOME number of geometries. * NTOTCO tot number of cylinders in all geometries. * NTYPES number of cell types. * NTIDL lenght of type numbering. * NBLOCK number of blocks. * NSUR number of surfaces. * NVOL number of zones. * NTOTCL tot number of cylinders in exact geometry. * NUNKO old number of unknowns. * NSURO number of surfaces of each geometry. * NVOLO number of zones of each geometry. * MINDO min index values for all axes (rect/cyl). * MAXDO max index values for all axes (rect/cyl). * ICORDO principal axes direction (X/Y/Z) for meshes. * IDLDIM position of each geometry in cylinder numbering. * IDLGEO position of each geometry in the * geometry numbering scheme. * KEYGEO geometric key for each type. * IDLTYP position of each type in numbering scheme. * KEYTYP type key for each block. * IDLBLK position of each block in numbering scheme. * KEYCYL index of cylinders by block. * RMESHO real mesh values (rect/cyl). * IDLREM position of mesh values per geometry. * INDEXO index for search in 'rmesho'. * VOLSO volumes and surfaces for each geometry. * MATGEO material numbers corresponding to geometries. * KEYINT interface key (giving the connected surface). * MATTYP material numbers for zones of every type. * *Parameters: output * REMESH real mesh values (rect/cyl). * MINDIM min index values for all axes (rect/cyl). * MAXDIM max index values for all axes (rect/cyl). * ICORD principal axes direction (X/Y/Z) for meshes. * VOLSUR volume-surface vector of exact geometry. * KEYMRG merging vector of exact geometry. * INDEX numbering of surfaces and zones. * INCELL block numbering. * MATALB material types. * NSURC number of compressed surfaces. * NVOLC number of compressed zones. * *----------------------------------------------------------------------- * IMPLICIT NONE * INTEGER IPRT, NDIM, NGEOME, NTOTCO, NTYPES, > NTIDL, NBLOCK, NSUR, NVOL, NTOTCL, NUNKO, > NSURC, NVOLC INTEGER MAXGRI(3), > MAXDO(NTOTCO), MINDO(NTOTCO), ICORDO(NTOTCO), > NSURO(NGEOME), NVOLO(NGEOME), IDLDIM(NGEOME), > IDLGEO(NGEOME), IDLREM(NGEOME), KEYGEO(NTYPES), > IDLTYP(NTYPES), > KEYTYP(NBLOCK), IDLBLK(NBLOCK), KEYCYL(NBLOCK), > INDEXO(4,*), MATGEO(*), > KEYINT(NUNKO), MATTYP(NTIDL), > MINDIM(NTOTCL), MAXDIM(NTOTCL), ICORD(NTOTCL), > INDEX(4,*), KEYMRG(*), MATALB(*), INCELL(*) REAL RMESHO(*), REMESH(*), VOLSO(*), VOLSUR(*) * INTEGER ICUR(4) INTEGER NUNK, IDLGE2, IG2, I4, N, ICX, IREM, I, J, K, > IBLK, ITYP, IGEO, IDLD, IDLR, MINABS, MAXABS, > J1, NTOTCX, MDMIN, NP1, NP2, IP1, IP2, IP3, > IOLD, ISU2, IVO2, ICREM, MINP1, MINP2, MINC, > ICYL, IDLTYX, IDLGEX, NO, NC, IMYG, IVSN, > IVS, IKREM REAL RSTART, RMINUS, XP1, XP2 CHARACTER TEMESH(4)*8 INTEGER IOUT PARAMETER ( IOUT=6 ) INTEGER NUMBLK, KL DATA TEMESH / 'X', 'Y', 'Z', 'C' / * NUMBLK(I,K)= I + IDLBLK(K) * * INITIALIZE: NO INTERFACE & PUT INDEXES TO 0. NUNK = NVOL + 1 - NSUR IDLGE2= 1 - NSUR DO 5 IG2= 1, NUNK VOLSUR(IG2)= 0.0 KEYMRG(IG2)= 0 MATALB(IG2)= 0 INCELL(IG2)= 0 DO 4 I4= 1,4 INDEX(I4,IG2)= 0 4 CONTINUE 5 CONTINUE * IF( IPRT.GE.1 )THEN WRITE(IOUT,'(1H )') WRITE(IOUT,'(/24H ====> GLOBAL MESHING )') ENDIF * * RECONSTRUCT CARTESIAN MESH J= 0 ICUR(1)= 1 ICUR(2)= 1 ICUR(3)= 1 IDLD=0 DO 30 N= 1, 3 RSTART= 0.0 ICORD(N)= N MINDIM(N)= J+1 * * SCANNING CELLS ON THE AXIS #N DO 20 ICX= 1, MAXGRI(N) ICUR(N)= ICX IF( NDIM.EQ.2 )THEN IBLK= MAXGRI(1) * (ICUR(2) - 1) + ICUR(1) ELSE IBLK= MAXGRI(1)*(MAXGRI(2)*ICUR(3)+ICUR(2)- > MAXGRI(2))+ICUR(1)-MAXGRI(1) ENDIF ITYP= KEYTYP(IBLK) IGEO= KEYGEO(ITYP) IDLD= IDLDIM(IGEO) IDLR= IDLREM(IGEO) MINABS= MINDO(IDLD+N) MAXABS= MAXDO(IDLD+N) RMINUS= RSTART - RMESHO(IDLR+MINABS) DO 10 IREM= MINABS, MAXABS-1 J= J+1 REMESH(J)= RMESHO(IDLR+IREM)+RMINUS 10 CONTINUE ICUR(N)= 1 RSTART= RMESHO(IDLR+MAXABS)+RMINUS 20 CONTINUE J= J+1 REMESH(J)= RSTART MAXDIM(N)= J IF( IPRT.GE.1.AND.N.LE.NDIM )THEN WRITE(IOUT,'(8X,A1,14H-COORDINATES: /(9X,5(1X,F13.6)))') > TEMESH(N), (REMESH(J1),J1=MINDIM(N),MAXDIM(N)) ENDIF 30 CONTINUE NTOTCX= 3 * * RECONSTRUCT CYLINDRICAL MESH IF( NDIM.EQ.2 )THEN MDMIN= 3 ELSE MDMIN= 1 ENDIF DO 130 N= MDMIN, 3 ICUR(N)= 1 NP1= MOD(N ,3) + 1 NP2= MOD(N+1,3) + 1 * * (XP1,XP2) ARE COORDINATES AT BEGINNING OF BLOCK (IP1,IP2) XP2= 0.0 DO 120 IP2= 1, MAXGRI(NP2) XP1= 0.0 DO 110 IP1= 1, MAXGRI(NP1) ICUR(NP1)= IP1 ICUR(NP2)= IP2 IF( NDIM.EQ.2 )THEN IBLK= MAXGRI(1) * (ICUR(2) - 1) + ICUR(1) ELSE IBLK= MAXGRI(1)*(MAXGRI(2)*ICUR(3)+ICUR(2)- > MAXGRI(2))+ICUR(1)-MAXGRI(1) ENDIF ITYP= KEYTYP(IBLK) IF( ITYP.EQ.0 ) GO TO 105 IGEO= KEYGEO(ITYP) IDLD= IDLDIM(IGEO) IDLR= IDLREM(IGEO) IF( IGEO.NE.NGEOME )THEN NC= IDLDIM(IGEO+1)-IDLD-3 ELSE NC= NTOTCO-IDLD-3 ENDIF IF( NC.EQ.1 )THEN IF( ICORDO(IDLD+4).EQ.N )THEN NTOTCX= NTOTCX+1 IF( NTOTCX.GT.NTOTCL ) > CALL XABORT( '** XELETR: TOO MANY CYLINDERS' ) MINP1 = MINDO(IDLD+NP1) MINP2 = MINDO(IDLD+NP2) MINC = MINDO(IDLD+4) ICORD(NTOTCX)= ICORDO(IDLD+4) * * RECENTER CYLINDERS REMESH(J+1)= RMESHO(IDLR+MINC-2)-RMESHO(IDLR+MINP1)+XP1 REMESH(J+2)= RMESHO(IDLR+MINC-1)-RMESHO(IDLR+MINP2)+XP2 J= J+2 MINDIM(NTOTCX)= J+1 DO 95 IREM= MINC, MAXDO(IDLD+4) J=J+1 REMESH(J)= RMESHO(IDLR+IREM) 95 CONTINUE MAXDIM(NTOTCX)= J IF( IPRT.GE.1 )THEN WRITE(IOUT,'(13H CELL(,I8,1H,,I8,1H,,I8,1H), > 3H (,A1,1H,,A1,10H)- CENTRE: , > 2H (,2(1X,F13.6),1H) )') > ICUR(1), ICUR(2), ICUR(3), > TEMESH(MOD(ICORD(NTOTCX) ,3)+1), > TEMESH(MOD(ICORD(NTOTCX)+1,3)+1), > REMESH(MINDIM(NTOTCX)-2), > REMESH(MINDIM(NTOTCX)-1) IF( NDIM.EQ.3 )THEN WRITE(IOUT,'(24X,A1,8H-RADII: /(25X,5(1X,F13.6)))') > TEMESH(ICORD(NTOTCX)), > (SQRT(REMESH(J1)),J1=MINDIM(NTOTCX),MAXDIM(NTOTCX)) ELSE WRITE(IOUT,'(26X,7HRADII: /(26X,5(1X,F13.6)))') > (SQRT(REMESH(J1)),J1=MINDIM(NTOTCX),MAXDIM(NTOTCX)) ENDIF ENDIF ENDIF ENDIF 105 CONTINUE IOLD= ICUR(NP2) ICUR(NP2)= 1 IF( NDIM.EQ.2 )THEN IBLK= MAXGRI(1) * (ICUR(2) - 1) + ICUR(1) ELSE IBLK= MAXGRI(1)*(MAXGRI(2)*ICUR(3)+ICUR(2)- > MAXGRI(2))+ICUR(1)-MAXGRI(1) ENDIF ITYP= KEYTYP(IBLK) IGEO= KEYGEO(ITYP) IDLD= IDLDIM(IGEO) IDLR= IDLREM(IGEO) MINABS= MINDO(IDLD+NP1) MAXABS= MAXDO(IDLD+NP1) XP1= XP1 + (RMESHO(IDLR+MAXABS)-RMESHO(IDLR+MINABS)) ICUR(NP2)= IOLD 110 CONTINUE ICUR(NP1)= 1 IF( NDIM.EQ.2 )THEN IBLK= MAXGRI(1) * (ICUR(2) - 1) + ICUR(1) ELSE IBLK= MAXGRI(1)*(MAXGRI(2)*ICUR(3)+ICUR(2)- > MAXGRI(2))+ICUR(1)-MAXGRI(1) ENDIF ITYP= KEYTYP(IBLK) IGEO= KEYGEO(ITYP) IDLD= IDLDIM(IGEO) IDLR= IDLREM(IGEO) MINABS= MINDO(IDLD+NP2) MAXABS= MAXDO(IDLD+NP2) XP2= XP2 + (RMESHO(IDLR+MAXABS)-RMESHO(IDLR+MINABS)) 120 CONTINUE 130 CONTINUE * * REESTABLISH INDEXING OF ALL UNKNOWNS * NOW, *ICUR()* IS THE INCREMENT FOR CARTESIAN CELL MESHING ISU2= 0 IVO2= 0 ICREM = 0 ICUR(3)= 0 DO 230 IP3= 1,MAXGRI(3) ICUR(2)= 0 DO 220 IP2= 1,MAXGRI(2) ICUR(1)= 0 DO 210 IP1= 1,MAXGRI(1) IF( NDIM.EQ.2 )THEN IBLK= MAXGRI(1)*(IP2-1)+IP1 ELSE IBLK= MAXGRI(1)*(MAXGRI(2)*IP3+IP2-MAXGRI(2))+IP1-MAXGRI(1) ENDIF ITYP= KEYTYP(IBLK) ICYL= KEYCYL(IBLK) IGEO= KEYGEO(ITYP) IDLTYX= IDLTYP(ITYP) IDLD= IDLDIM(IGEO) IDLGEX= IDLGEO(IGEO) IKREM = ICREM DO 200 IVS= 1, NVOLO(IGEO) NO= NUMBLK(IVS, IBLK) IMYG=0 IF( KEYINT(NO).NE.0 ) GO TO 200 IMYG=MATGEO(IDLGEX+IVS) IVO2= IVO2 + 1 IVSN= IVO2 IF( IMYG.GE.0 )THEN IF( IVO2.GT.NVOL ) > CALL XABORT( '** XELETR: TOO MANY ZONES' ) KEYMRG( IDLGE2+IVSN)= IMYG+ICREM VOLSUR( IDLGE2+IVSN)= VOLSO( IDLGEX+IVS) MATALB( IDLGE2+IVSN)= MATTYP( IDLTYX+IVS) INDEX(1,IDLGE2+IVSN)= INDEXO(1,IDLGEX+IVS)+ICUR(1) > + (MINDIM(1)-MINDO(IDLD+1)) INDEX(2,IDLGE2+IVSN)= INDEXO(2,IDLGEX+IVS)+ICUR(2) > + (MINDIM(2)-MINDO(IDLD+2)) INDEX(3,IDLGE2+IVSN)= INDEXO(3,IDLGEX+IVS)+ICUR(3) > + (MINDIM(3)-MINDO(IDLD+3)) INDEX(4,IDLGE2+IVSN)= 0 INCELL( IDLGE2+IVSN)= IBLK IF( ICYL.NE.0 )THEN IF( INDEXO(4,IDLGEX+IVS).NE.MAXDO(IDLD+4) )THEN * IF WE ARE INSIDE THE CYLINDER: INDEX(4,IDLGE2+IVSN)= INDEXO(4,IDLGEX+IVS) > + (MINDIM(ICYL)-MINDO(IDLD+4)) ENDIF ENDIF IKREM=IKREM+1 ELSE KEYMRG( IDLGE2+IVSN)= 0 INCELL( IDLGE2+IVSN)= IBLK ENDIF 200 CONTINUE ICREM=IKREM DO 400 IVS= -1,NSURO(IGEO),-1 NO= NUMBLK(IVS, IBLK) IMYG=0 IF( KEYINT(NO).NE.0 ) GO TO 400 IMYG=MATGEO(IDLGEX+IVS) IF( IMYG.LT.0 )THEN ISU2= ISU2 - 1 IVSN= ISU2 IF( ISU2.LT. NSUR ) > CALL XABORT( '** XELETR: TOO MANY SURFACES' ) KEYMRG( IDLGE2+IVSN)= IVSN VOLSUR( IDLGE2+IVSN)= VOLSO( IDLGEX+IVS) MATALB( IDLGE2+IVSN)= MATTYP( IDLTYX+IVS) INDEX(1,IDLGE2+IVSN)= INDEXO(1,IDLGEX+IVS)+ICUR(1) > + (MINDIM(1)-MINDO(IDLD+1)) INDEX(2,IDLGE2+IVSN)= INDEXO(2,IDLGEX+IVS)+ICUR(2) > + (MINDIM(2)-MINDO(IDLD+2)) INDEX(3,IDLGE2+IVSN)= INDEXO(3,IDLGEX+IVS)+ICUR(3) > + (MINDIM(3)-MINDO(IDLD+3)) INDEX(4,IDLGE2+IVSN)= 0 INCELL( IDLGE2+IVSN)= IBLK IF( ICYL.NE.0 )THEN IF( INDEXO(4,IDLGEX+IVS).NE.MAXDO(IDLD+4) )THEN * IF WE ARE INSIDE THE CYLINDER: INDEX(4,IDLGE2+IVSN)= INDEXO(4,IDLGEX+IVS) > + (MINDIM(ICYL)-MINDO(IDLD+4)) ENDIF ENDIF ENDIF 400 CONTINUE ICUR(1)= ICUR(1) + (MAXDO(IDLD+1)-MINDO(IDLD+1)) 210 CONTINUE ICUR(2)= ICUR(2) + (MAXDO(IDLD+2)-MINDO(IDLD+2)) 220 CONTINUE ICUR(3)= ICUR(3) + (MAXDO(IDLD+3)-MINDO(IDLD+3)) 230 CONTINUE *---- * REMOVE ZONES AND SURFACES WITH VANISHING VOLSUR *---- IVS=0 DO 410 ISU2=NSUR,-1 IF(VOLSUR(ISU2-NSUR+1) .GT. 0.0) THEN IVS=IVS+1 VOLSUR(IVS)=VOLSUR(ISU2-NSUR+1) MATALB(IVS)=MATALB(ISU2-NSUR+1) KEYMRG(IVS)=KEYMRG(ISU2-NSUR+1) INCELL(IVS)=INCELL(ISU2-NSUR+1) DO 411 J1=1,4 INDEX(J1,IVS)=INDEX(J1,ISU2-NSUR+1) 411 CONTINUE ENDIF 410 CONTINUE NSURC=-IVS IVS=IVS+1 VOLSUR(IVS)=0.0 MATALB(IVS)=0 KEYMRG(IVS)=0 INCELL(IVS)=0 DO 420 J1=1,4 INDEX(J1,IVS)=0 420 CONTINUE DO 430 IVO2=1,NVOL IF(VOLSUR(IVO2-NSUR+1) .GT. 0.0) THEN IVS=IVS+1 VOLSUR(IVS)=VOLSUR(IVO2-NSUR+1) MATALB(IVS)=MATALB(IVO2-NSUR+1) KEYMRG(IVS)=KEYMRG(IVO2-NSUR+1) INCELL(IVS)=INCELL(IVO2-NSUR+1) DO 431 J1=1,4 INDEX(J1,IVS)=INDEX(J1,IVO2-NSUR+1) 431 CONTINUE ENDIF 430 CONTINUE NVOLC=IVS+NSURC-1 KL=1-NSURC IF( IPRT.GE.5 )THEN WRITE(IOUT,'(1H )') WRITE(IOUT,'(/13H RENUMBERING ,I8,13H VOLUMES AND ,'// > 'I8,10H SURFACES.)') NVOL,-NSUR WRITE(IOUT,'(20H CARTESIAN MESH ,7HMINDIM=,3I8)') > (MINDIM(J1),J1=1,3) WRITE(IOUT,'(20X ,7HMAXDIM=,3I8)') > (MAXDIM(J1),J1=1,3) IF( NTOTCL.GT.3 )THEN DO 540 J1= 4, NTOTCL WRITE(IOUT,'(10H CYLINDER ,I8,6X ,7HMINDIM=,15X,I8)') > J1-3,MINDIM(J1) WRITE(IOUT,'(20X ,7HMAXDIM=,15X,I8)') > MAXDIM(J1) 540 CONTINUE ENDIF DO 550 IVS= NSURC, NVOLC IF( IVS.LT.0 )THEN IF( KEYMRG(IVS+KL) .EQ. 0 )THEN WRITE(IOUT,'(8H KEYMRG(,I8,2H)=,I8, > 7H INDEX=,4I8,7H BLOCK=,I8,9H SURFACE=,F20.7, > 17H ABSENT FROM CELL)') > IVS,KEYMRG(IVS+KL),(INDEX(J1,IVS+KL),J1=1,4), > INCELL(IVS+KL),4.*VOLSUR(IVS+KL) ELSE WRITE(IOUT,'(8H KEYMRG(,I8,2H)=,I8, > 7H INDEX=,4I8,7H BLOCK=,I8,9H SURFACE=,F20.7)') > IVS,KEYMRG(IVS+KL),(INDEX(J1,IVS+KL),J1=1,4), > INCELL(IVS+KL),4.*VOLSUR(IVS+KL) ENDIF ELSE IF( KEYMRG(IVS+KL) .EQ. 0 )THEN WRITE(IOUT,'(8H KEYMRG(,I8,2H)=,I8, > 7H INDEX=,4I8,7H BLOCK=,I8,9H VOLUME= ,F20.7, > 17H ABSENT FROM CELL)') > IVS,KEYMRG(IVS+KL),(INDEX(J1,IVS+KL),J1=1,4), > INCELL(IVS+KL),VOLSUR(IVS+KL) ELSE WRITE(IOUT,'(8H KEYMRG(,I8,2H)=,I8, > 7H INDEX=,4I8,7H BLOCK=,I8,9H VOLUME= ,F20.7)') > IVS,KEYMRG(IVS+KL),(INDEX(J1,IVS+KL),J1=1,4), > INCELL(IVS+KL),VOLSUR(IVS+KL) ENDIF ENDIF 550 CONTINUE ENDIF RETURN END