*DECK AXGXEL SUBROUTINE AXGXEL(IPGEOM,IPTRKM,IPRINT,GEONAM) * *----------------------------------------------------------------------- * *Purpose: * Analyze XEL geometry for original Excell tracking with XELTRK module. * *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): G. Marleau * *Parameters: input * IPGEOM geometry data structure pointer. * IPTRKM tracking data structure pointer. * IPRINT print level. * GEONAM geometry name. * *----------------------------------------------------------------------- * USE GANLIB IMPLICIT NONE INTEGER IOUT,NALB,MREGIO,MXDIM,NSTATE CHARACTER NAMSBR*6 PARAMETER (IOUT=6,NALB=6,MREGIO=100000,MXDIM=3,NSTATE=40, > NAMSBR='AXGXEL') *---- * ROUTINE PARAMETERS *---- TYPE(C_PTR) IPGEOM TYPE(C_PTR) IPTRKM INTEGER IPRINT CHARACTER*12 GEONAM *---- * LOCAL VARIABLES *---- INTEGER NCODE(NALB),ICODE(NALB) REAL ALBEDO(NALB) INTEGER MAXGRI(MXDIM),LCLSYM(MXDIM),LCLTRA(MXDIM), > MRGSUR(-NALB:-1) INTEGER ISTATE(NSTATE) LOGICAL LEAKSW,LL1,LL2,L1CELL INTEGER NDIM,NTYPO,NBLOCK,NBMIX,NEXTGE,IFCSYM INTEGER NTOTCO,MAXRO,NGEOME,NGIDL,NTIDL,NUNKO INTEGER NTYP,NTOTCL,MAXR INTEGER NSUR,NSURC,NVOL,NVOLC,NUNK,NSBC *---- * ALLOCATABLE ARRAYS *---- INTEGER, ALLOCATABLE, DIMENSION(:) :: MRGCEL, NSURO, NVOLO,IDLGEO, > IDLDIM,KEYGEO,IDLTYP,KEYTYP,IDLBLK,KCELLG,KEYTRN,IDLREM, MINDO, > MAXDO,ICORDO,MATGEO,INDEXO,MATTYP,KEYINT,KEYCYL,KEYMRG,MATALB, > MINDIM,MAXDIM, ICORD,INCELL, MATRT, INDEX REAL, ALLOCATABLE, DIMENSION(:) :: REMSHO,VOLSRO,VOLSUR,REMESH *---- * GET DIMENSIONING INFORMATION *---- CALL XELPRP( IPGEOM, GEONAM, NDIM, NTYPO , NBLOCK, NBMIX, > MAXGRI, ALBEDO, ICODE, NCODE, LCLSYM, LCLTRA, > MRGSUR, LEAKSW, LL1, LL2, L1CELL, NEXTGE, > IFCSYM, IPRINT) *---- * ALLOCATE MEMORY - 1 *---- ALLOCATE(MRGCEL(NBLOCK),NSURO(NBLOCK),NVOLO(NBLOCK), > IDLGEO(NBLOCK),IDLDIM(NBLOCK),KEYGEO(NBLOCK),IDLTYP(NBLOCK), > KEYTYP(NBLOCK),IDLBLK(NBLOCK),KCELLG(3*NBLOCK),KEYTRN(NBLOCK)) *---- * READ GEOMETRY BLOCK DESCRIPTION *---- CALL XELDCL(IPGEOM,GEONAM,NDIM ,MAXGRI,LCLSYM,NBLOCK,NTYPO , > LL1 ,LL2 ,IPRINT,NTOTCO,MAXRO ,NGEOME,NTYP , > NGIDL ,NTIDL ,NUNKO ,KCELLG,NSURO ,NVOLO ,IDLDIM, > IDLGEO,KEYTRN,KEYGEO,IDLTYP,KEYTYP,MRGCEL,IDLBLK) *---- * ALLOCATE MEMORY - 2 *---- ALLOCATE(IDLREM(NGEOME),MINDO(NTOTCO),MAXDO(NTOTCO), > ICORDO(NTOTCO),MATGEO(NGIDL),INDEXO(4*NGIDL)) ALLOCATE(REMSHO(MAXRO),VOLSRO(NGIDL)) *---- * PRODUCE REGION NUMBERING AND VOLUME EVALUATION *---- CALL XELTRP(IPGEOM,NGIDL ,NDIM ,NGEOME,L1CELL,NTOTCO,NEXTGE, > MAXRO ,IPRINT,KCELLG,NSURO ,NVOLO ,IDLDIM,IDLGEO, > KEYTRN,MAXDO ,MINDO ,ICORDO,REMSHO,IDLREM,INDEXO, > VOLSRO,MATGEO) *---- * RELEASE SOME MEMORY *---- DEALLOCATE(KEYTRN) *---- * ALLOCATE MEMORY - 3 *---- ALLOCATE(MATTYP(NTIDL),KEYINT(NUNKO)) *---- * INTERFACE ALL CELLS IN THE GEOMETRY *---- CALL XELBIN(IPGEOM,NDIM ,NGEOME,L1CELL, NTYP, NGIDL,NTIDL , > NBLOCK,MAXGRI,NUNKO ,IPRINT,KCELLG, NSURO,NVOLO , > IDLGEO,MATGEO,KEYGEO,IDLTYP,IDLBLK,KEYTYP,MATTYP, > KEYINT) *---- * ALLOCATE MEMORY - 4 *---- ALLOCATE(KEYCYL(NBLOCK)) *---- * COMPUTE ALLOCATION IN EXACT GEOMETRY. *---- CALL XELEDC(NDIM ,MAXGRI,NGEOME,NTOTCO,NTYP ,NBLOCK,NUNKO , > NSURO ,NVOLO ,MINDO ,MAXDO ,ICORDO,IDLDIM,KEYGEO, > KEYTYP,IDLBLK,KEYINT,NTOTCL,MAXR ,NSUR ,NVOL , > KEYCYL) NUNK= NVOL + 1 - NSUR *---- * ALLOCATE MEMORY - 5 *---- ALLOCATE(KEYMRG(NUNK),MATALB(NUNK),MINDIM(NTOTCL),MAXDIM(NTOTCL), > ICORD(NTOTCL),INDEX(4*NUNK),INCELL(NUNK)) ALLOCATE(VOLSUR(NUNK),REMESH(MAXR)) *---- * TO RECONSTRUCT THE MESH IN EXACT GEOMETRY. *---- CALL XELETR(IPRINT,NDIM ,MAXGRI,NGEOME,NTOTCO,NTYP ,NTIDL , > NBLOCK,NSUR ,NVOL ,NTOTCL,NUNKO ,NSURO ,NVOLO , > MINDO, MAXDO ,ICORDO,IDLDIM,IDLGEO,KEYGEO,IDLTYP, > KEYTYP,IDLBLK,KEYCYL,REMSHO,IDLREM,INDEXO,VOLSRO, > MATGEO,KEYINT,MATTYP,REMESH,MINDIM,MAXDIM,ICORD , > VOLSUR,KEYMRG,INDEX ,INCELL,MATALB,NSURC ,NVOLC ) NSUR=NSURC NVOL=NVOLC NUNK= NVOL + 1 - NSUR DEALLOCATE(KEYCYL,KEYINT,MATTYP,INDEXO,MATGEO,ICORDO,MAXDO,MINDO, > IDLBLK,KEYTYP,IDLTYP,KEYGEO,IDLDIM,IDLREM,KCELLG,IDLGEO,NVOLO, > NSURO) DEALLOCATE(VOLSRO,REMSHO) *---- * ALLOCATE MEMORY - 6 *---- ALLOCATE(MATRT(-NSUR*2)) *---- * PREPARE MERGING OF ZONES AND SURFACES USING BOUNDARY CONDITIONS. * SET UP REFLECTION-TRANSMISSION MATRIX *---- CALL XELMRG(IPRINT,NSUR ,NVOL ,NSBC ,NTOTCL,INDEX ,MINDIM, > MAXDIM,LCLSYM,LCLTRA,LL1 ,LL2 ,MRGCEL,MATALB, > KEYMRG,INCELL,MATRT ) *---- * SAVE EXCELL TRACKING FOR CARTESIAN GEOMETRY *---- CALL LCMSIX(IPTRKM,'EXCELL ',1) ISTATE(:NSTATE)=0 ISTATE(1)=NDIM ISTATE(2)=-NSUR ISTATE(3)=NVOL ISTATE(4)=NTOTCL ISTATE(5)=MAXR ISTATE(6)=NUNK ISTATE(7)=NEXTGE ISTATE(8)=LCLSYM(1) ISTATE(9)=LCLSYM(2) IF(NDIM .EQ. 3) ISTATE(10)=LCLSYM(3) *---- * LL1 is for diagonal symmetry * with region Pi/4 to Pi/2 defined in x-y plane * LL2 is for diagonal symmetry * with region 0 to Pi/4 defined in x-y plane *---- IF(LL1) THEN ISTATE(11)=-1 ELSE IF(LL2) THEN ISTATE(11)=1 ENDIF CALL LCMPUT(IPTRKM,'MINDIM ',NTOTCL,1,MINDIM) CALL LCMPUT(IPTRKM,'MAXDIM ',NTOTCL,1,MAXDIM) CALL LCMPUT(IPTRKM,'ICORD ',NTOTCL,1,ICORD ) CALL LCMPUT(IPTRKM,'INDEX ',4*NUNK,1,INDEX ) CALL LCMPUT(IPTRKM,'REMESH ',MAXR ,2,REMESH) CALL LCMPUT(IPTRKM,'KEYMRG ',NUNK ,1,KEYMRG) CALL LCMPUT(IPTRKM,'MATALB ',NUNK ,1,MATALB) CALL LCMPUT(IPTRKM,'VOLSUR ',NUNK ,2,VOLSUR) CALL LCMPUT(IPTRKM,'STATE-VECTOR',NSTATE,1,ISTATE) CALL LCMSIX(IPTRKM,'EXCELL ',2) *---- * SAVE REFLECTION-TRANSMISSION MATRIX *---- CALL LCMPUT(IPTRKM,'BC-REFL+TRAN',NSBC,1,MATRT) CALL LCMPUT(IPTRKM,'ALBEDO ',6 ,2,ALBEDO ) CALL LCMPUT(IPTRKM,'ICODE ',6 ,1,ICODE ) CALL LCMPUT(IPTRKM,'NCODE ',6 ,1,NCODE ) DEALLOCATE(MATRT) *---- * RELEASE REMAINING MEMORY *---- DEALLOCATE(INCELL,INDEX,ICORD,MAXDIM,MINDIM,MATALB,KEYMRG,MRGCEL) DEALLOCATE(REMESH,VOLSUR) RETURN END