diff options
Diffstat (limited to 'Dragon/src/XELDRV.f')
| -rw-r--r-- | Dragon/src/XELDRV.f | 620 |
1 files changed, 620 insertions, 0 deletions
diff --git a/Dragon/src/XELDRV.f b/Dragon/src/XELDRV.f new file mode 100644 index 0000000..118c1d6 --- /dev/null +++ b/Dragon/src/XELDRV.f @@ -0,0 +1,620 @@ +*DECK XELDRV + SUBROUTINE XELDRV(IPTRK ,IPGEOM,IPRT ,MAXPTS,NANIS ,NORE , + > LMERG ,KSPEC ,KTOPT ,TITREC,CUTOFX,CFTRAK, + > IFTRAK,IDISP ,ISYMM ,LCACT ,NMU ,INSB , + > NBATCH,LBIHET,LPRISM,IZ,DELU,FRTM) +* +*----------------------------------------------------------------------- +* +*Purpose: +* Read a Dragon tracking file to compute pij, normalize a tracking +* file to Dragon format and produce a new tracking file in Dragon +* format. +* +*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 +* IPTRK pointer to the excell tracking (L_TRACK). +* IPGEOM pointer to the geometry (L_GEOM). +* IPRT tracking print level. +* MAXPTS number of zones according to user. +* NANIS anisotropy of the solution. +* NORE track normalization flag (<=0: yes; =1: no). +* LMERG type of volume normalization. +* KSPEC kind of pij integration (=0: isotr.; =1: spec.). +* KTOPT tracking type option. +* TITREC title for this case. +* CUTOFX mfp cutoff for specular integration. +* CFTRAK name of the sequential binary tracking file. +* IFTRAK unit of the sequential binary tracking file. +* IDISP mode of the sequential binary tracking file. +* LCACT type of polar integration for the method of characteristics. +* NMU number of polar angles for the method of characteristics. +* ISYMM symmetry factor. +* INSB type of vectorization for the calculation of CP matrices. +* NBATCH number of tracks assigned to each OpenMP core. +* LBIHET activation flag for the double heterogeneity option. +* LPRISM flag for 3D prismatic geometry. +* IZ projection axis for 3D prismatic geometry. +* DELU user defined track spacing for 3D prismatic tracking. +* FRTM minimum volume fraction of the grain in the representative +* volume for She-Liu-Shi model. +* +*----------------------------------------------------------------------- +* + USE GANLIB + IMPLICIT NONE +*---- +* SUBROUTINE ARGUMENTS +*---- + CHARACTER TITREC*72,CFTRAK*12 + TYPE(C_PTR) IPTRK,IPGEOM + INTEGER IPRT,MAXPTS,NANIS,NORE,LMERG,KSPEC,KTOPT,IFTRAK, + > IDISP,ISYMM,LCACT,NMU,INSB,NBATCH,IZ + REAL CUTOFX,DELU,FRTM + LOGICAL LPRISM,LBIHET +*---- +* LOCAL VARIABLES +*---- + INTEGER NSTATE + PARAMETER (NSTATE=40) + INTEGER NREG,NUNKNO,IUTYPE,ISTATE(NSTATE),IFTEMP,IFILE, + > ITYPE,ITOPT,ITROP,NCOMNT,NTRK,IREC,IC,IR,JR,IUNK, + > NSOUT,IDISPO,NDIM,NV,NS,NALBGO,NCOR,NANGL,MXSEG, + > NPRISM,NDIMO,NSO,NVO,NUNOLD,KDROPN,KDRCLS,NUNKNX, + > IOUT,ITGEO,IUSED(6),ICMAX,ICODE(6),ICOLD(6), + > NANGLO,MXSUB,MXSUBO,MXSEGO,ILONG,IFMT,I + LOGICAL LEAKSW, LELCHK, SWNOGE, SWCONS, EMPTY, LCM + REAL ALBEDO(6),ALBOLD(6),EXTKOP(NSTATE), + > ZERO,ONE,DENS,PCORN + DOUBLE PRECISION DASCRP + CHARACTER GEONAM*12,CORIEN(0:3,6)*4,CUSED(0:1)*6,TEXT12*12, + > COMENT*80,CTRK*4 +*---- +* ALLOCATABLE ARRAYS +*---- + INTEGER, ALLOCATABLE, DIMENSION(:) :: MATCOD,KEYFLX,MATOLD,MATALB, + > KEYMRG,MATMRG + REAL, ALLOCATABLE, DIMENSION(:) :: VOLUME,VOLOLD,VOLSUR,VOLMRG +* + PARAMETER ( IUTYPE=2, IOUT=6, ZERO=0.0, ONE=1.0 ) +* + DATA (( CORIEN(JR,IR),IR=1,6),JR=0,3) + > / ' 1 ',' 2 ',' 3 ',' 4 ',' 5 ',' 6 ', + > '****',' R+ ','****','****',' Z- ',' Z+ ', + > 'HBC ','****','****','****',' Z- ',' Z+ ', + > ' X- ',' X+ ',' Y- ',' Y+ ',' Z- ',' Z+ '/ + DATA ( CUSED(JR),JR=0,1 ) / 'UNUSED',' USED' / +*---- +* SCRATCH STORAGE ALLOCATION +* MATCOD material numbers for zones in the supercell. +* VOLUME volumes of zones in the supercell. +* KEYFLX zone key for the unknown vectors (fluxes...). +*---- + ALLOCATE(MATCOD(MAXPTS),KEYFLX(MAXPTS)) + ALLOCATE(VOLUME(MAXPTS)) +* + NPRISM=0 + IF( IPRT.GT.0 ) WRITE(IOUT,'(1X,A72//)') TITREC + SWNOGE= .NOT.C_ASSOCIATED(IPGEOM) + IF(SWNOGE) THEN + GEONAM=' ' + IF(INSB.EQ.2) CALL XABORT('XELDRV: GEOMETRY REQUESTED') + ELSE + CALL LCMINF(IPGEOM,GEONAM,TEXT12,EMPTY,ILONG,LCM) + ENDIF + NTRK = 0 +* + IF( IPRT.GT.0 )THEN + WRITE(IOUT,'(1H )') + IF( SWNOGE )THEN + WRITE(IOUT,'(27H ECHO = >>> NO GEOMETRY )') + ELSE + WRITE(IOUT,'(27H ECHO = >>> GEOMETRY NAME: ,A8)') GEONAM + ENDIF + WRITE(IOUT,'(27H ECHO = >>> TRACKING FILE: ,A8)') CFTRAK + IF( IDISP.EQ.-1 )THEN + WRITE(IOUT,'(27H ECHO = >>> DISP: ,A4)') 'MODT' + ELSEIF( IDISP.EQ. 0 )THEN + WRITE(IOUT,'(27H ECHO = >>> DISP: ,A4)') 'OLDT' + ELSEIF( IDISP.EQ.+1 )THEN + WRITE(IOUT,'(27H ECHO = >>> DISP: ,A4)') 'NEWT' + ENDIF + IF( NORE.EQ.-1 )THEN + WRITE(IOUT,'(36H ECHO = >>> NORMALIZED-BY ANGLE )') + ELSEIF( NORE.EQ. 0 )THEN + WRITE(IOUT,'(36H ECHO = >>> NORMALIZED-GLOBAL )') + ELSEIF( NORE.EQ.+1 )THEN + WRITE(IOUT,'(36H ECHO = >>> NOT NORMALIZED )') + ENDIF + ENDIF +*---- +* 1) REWIND TRACKING FILE -------------------------------------------- +*---- + IF((IFTRAK.EQ.0).AND.(INSB.NE.2)) THEN + CALL XABORT('XELDRV: NO SEQUENTIAL BINARY TRACKING FILE YET D' + > //'EFINED') + ELSE IF((IFTRAK.NE.0).AND.(INSB.EQ.2)) THEN + CALL XABORT('XELDRV: NO SEQUENTIAL BINARY TRACKING FILE EXPEC' + > //'TED WITH OPTION XCLL') + ENDIF + IF(INSB.NE.2) REWIND IFTRAK +*---- +* 1.2) GET HEADER INFORMATIONS FROM *OLDT*/*MODT* FILES +*---- + NUNOLD= 0 + IFMT= 0 + IF( IDISP.LE.0 )THEN + IREC= 1 + READ(IFTRAK,ERR=997) CTRK,NCOMNT,NTRK,IFMT + DO 10 IC= 1, NCOMNT + IREC= IREC+1 + READ (IFTRAK,ERR=997) COMENT + 10 CONTINUE + IREC= IREC+1 + READ (IFTRAK,ERR=997) NDIMO,ITOPT,NVO,NSO,NALBGO, + > NCOR,NANGL,MXSUB,MXSEG + IF( NALBGO.LE.0.OR.NALBGO.GT.6 )THEN + CALL XABORT('XELDRV: NALBG.GT.6.OR.NALBG.LE.0'// + > ' ON TRACKING FILE') + ENDIF + NUNOLD= NVO+NSO+1 + ALLOCATE(VOLOLD(NUNOLD),MATOLD(NUNOLD)) + IREC= IREC+1 + READ (IFTRAK,ERR=997) (VOLOLD(IR),IR=1,NUNOLD) + IREC= IREC+1 + READ (IFTRAK,ERR=997) (MATOLD(IR),IR=1,NUNOLD) + IREC= IREC+1 + READ (IFTRAK,ERR=997) ( ICOLD(IR),IR=1,NALBGO) + IREC= IREC+1 + READ (IFTRAK,ERR=997) (ALBOLD(IR),IR=1,NALBGO) + IREC= IREC+1 + READ (IFTRAK,ERR=997) (DASCRP,IR=0,NDIMO*NANGL-1) + IREC= IREC+1 + READ (IFTRAK,ERR=997) (DASCRP,IR=0,NANGL-1) + REWIND IFTRAK + ENDIF +*---- +* 1.3) OPEN TEMP TRACKING FILE FOR *MODT*/*NEWT* FILES +*---- + ITROP = 0 + IF((IDISP.NE.0).AND.(INSB.NE.2)) THEN + IFILE= KDROPN('DUMMYSQ',0,IUTYPE,0) + IF( IFILE.LE.0 ) GO TO 998 + IF( IFILE.EQ.IFTRAK ) CALL XABORT('XELDRV: BAD TRACKING UNIT') + IFTEMP = IFILE + REWIND IFTEMP + IF( IDISP.LT.0 )THEN +* +* FOR *MODT* FILES, MAIN TRACKING IS COPIED ON TEMPORARY + CALL XELCOP( IFTRAK, IFTEMP ) + ENDIF + ENDIF +*---- +* 2) GET GEOMETRIC INFORMATIONS AND TRACK IF NECESSARY---------------- +*---- + IF( SWNOGE )THEN +*---- +* 2.1) NO GEOMETRY, GET INFORMATIONS FROM *OLDT*/*MODT* FILE +*---- + IF(IDISP.GT.0) CALL XABORT('XELDRV: A RHS BINARY TRACKING FIL' + > //'E OR A RHS GEOMETRY MUST BE DEFINED.') + NDIM= NDIMO + NSOUT= NSO + NREG= NVO + NS= NSO + NV= NVO + NUNKNX= NUNOLD + IF( NREG.GT.MAXPTS ) THEN + WRITE(IOUT,'(28H ****** XELDRV ERROR ******,/ + > 28H NUMBER OF REGION COMPUTED =,I10/ + > 28H MAXIMUM NUMBER OF REGION =,I10)') NREG,MAXPTS + CALL XABORT('XELDRV: MAXR TOO SMALL') + ENDIF + ALLOCATE(VOLSUR(NUNKNX),MATALB(NUNKNX),KEYMRG(NUNKNX)) + IUNK= 0 + DO 20 IR= -NS, NV + VOLSUR(IUNK+1)= VOLOLD(IUNK+1) + MATALB(IUNK+1)= MATOLD(IUNK+1) + KEYMRG(IUNK+1)= IR + IUNK= IUNK+1 + 20 CONTINUE + ALLOCATE(VOLMRG(NUNKNX),MATMRG(NUNKNX)) + DO 21 IUNK=1,NUNKNX + VOLMRG(IUNK)= VOLOLD(IUNK) + MATMRG(IUNK)= MATOLD(IUNK) + 21 CONTINUE + DEALLOCATE(MATOLD,VOLOLD) + DO 25 IR= 1, NALBGO + ICODE(IR)= ICOLD(IR) + 25 CONTINUE + ITGEO= 0 + ELSE +*---- +* 2.2) THERE IS A GEOMETRY, GO TO EXCELL MODULES TO ANALYZE IT +*---- + ISTATE(:NSTATE)=0 + CALL LCMGET(IPGEOM,'STATE-VECTOR',ISTATE) + ITYPE= ISTATE(1) + IF( ITYPE.EQ.3.OR.ITYPE.EQ.6 )THEN + ITGEO= 1 + ELSEIF( ITYPE.EQ. 8 .OR. ITYPE.EQ. 9 .OR. + > ITYPE.EQ.24 .OR. ITYPE.EQ.25 )THEN + ITGEO= 2 + ELSEIF( ITYPE.EQ. 5 .OR. ITYPE.EQ. 7 .OR. ITYPE.EQ.20 .OR. + > ITYPE.EQ.21 .OR. ITYPE.EQ.22 .OR. ITYPE.EQ.23 )THEN + ITGEO= 3 + ELSE + ITGEO= 0 + ENDIF + IDISPO= IDISP + NANGLO= NANGL + MXSUBO= MXSUB + MXSEGO= MXSEG + IF((INSB.EQ.2).AND.(ITGEO.NE.3)) THEN + CALL XABORT('XELDRV: XCELL TRACKING NOT AVAILABLE.') + ENDIF + IF( ISTATE(13).GE.1 )THEN + IF( ITYPE.EQ.3.OR.ITYPE.EQ.20.OR.ITYPE.EQ.24 )THEN +*---- +* 2.2.1.1) EXCELL DRIVER FOR CLUSTER SINGLE CELLS +*---- + CALL XCWTRK(IPTRK ,IPGEOM,GEONAM,IDISP ,IFTEMP, + > IPRT ,NDIM ,ITOPT ,NV ,NS ,NANGL , + > ISYMM ,DENS ,PCORN ,MXSUB ,MXSEG ,ICODE , + > TITREC) + ITROP=3 + ELSE + CALL XABORT('XELDRV: ONLY ONE-CELL TUBE/CARCEL/HEXCEL'// + > ' CLUSTERS ARE AVAILABLE') + ENDIF + ELSEIF( ITGEO.EQ.2 )THEN +*---- +* 2.2.1.2) EXCELL DRIVER FOR HEXAGONAL 2D/3D ASSEMBLIES +*---- + CALL XHXTRK(IPTRK ,IPGEOM,GEONAM,IDISP,IFTEMP, + > IPRT ,NDIM ,ITOPT ,NV ,NS ,NANGL , + > ISYMM ,DENS ,PCORN ,MXSEG,ICODE ,TITREC) + MXSUB=1 + ITROP=2 + ELSEIF( ITGEO.EQ.3 )THEN +*---- +* 2.2.1.3) EXCELL DRIVER FOR CARTESIAN 2D/3D ASSEMBLIES +*---- + CALL XELTRK(IPTRK ,IPGEOM,GEONAM,IDISP ,IFTEMP, + > IPRT ,NDIM ,ITOPT ,NV ,NS ,NANGL , + > ISYMM ,DENS ,PCORN ,MXSUB ,MXSEG ,ICODE , + > TITREC,INSB ,IZ ,LPRISM,NPRISM) + ITROP=1 +*---- +* For case with intrinsic symmetry +* tracking performed on unfolded geometry assuming angular and spatial +* symmetry +* Normalization must be on global volume since only this option +* makes sense. +*---- + IF((ISYMM .GT. 1).AND.(LMERG .EQ. 0)) LMERG=1 + ELSE + CALL XABORT('XELDRV: INVALID TYPE OF GEOMETRY') + ENDIF + IF((INSB.EQ.2).AND.(NDIM.NE.3)) THEN + CALL XABORT('XELDRV: XCELL OPTION LIMITED TO 3D GEOMETRY.') + ENDIF +*---- +* 2.2.1.4) RECOVER KEYMRG, MATALB AND VOLSUR +*---- + NUNKNX= NV+NS+1 + CALL LCMSIX(IPTRK,'EXCELL ',1) + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + IF(NUNKNX.NE.ISTATE(6)) CALL XABORT('XELDRV: INVALID NUNKNX.') + ALLOCATE(VOLSUR(NUNKNX),MATALB(NUNKNX),KEYMRG(NUNKNX)) + CALL LCMGET(IPTRK,'KEYMRG ',KEYMRG) + CALL LCMGET(IPTRK,'MATALB ',MATALB) + CALL LCMGET(IPTRK,'VOLSUR ',VOLSUR) + CALL LCMSIX(IPTRK,'EXCELL ',2) +*---- +* 2.2.2) MERGE SURFACES AND ZONES FOR THIS GEOMETRY +*---- + ALLOCATE(VOLMRG(NUNKNX),MATMRG(NUNKNX)) + CALL XELCMP( NS, NV, VOLSUR, MATALB, KEYMRG, + > NSOUT, NREG, VOLMRG, MATMRG, ITGEO, ICODE) + IF( NREG.GT.MAXPTS ) THEN + WRITE(IOUT,'(28H ****** XELDRV ERROR ******,/ + > 28H NUMBER OF REGION COMPUTED =,I10/ + > 28H MAXIMUM NUMBER OF REGION =,I10)') NREG,MAXPTS + CALL XABORT('XELDRV: MAXR TOO SMALL') + ENDIF + IF((IPRT.GE.1).AND.(INSB.NE.2)) THEN + WRITE(IOUT,6002) NANGL,ISYMM,CUTOFX,DENS,PCORN + ENDIF + IF(INSB.EQ.2) THEN + IF(IDISP.NE.99) CALL XABORT('XELDRV: INCONSISTENT IDISP') + CALL LCMGET(IPTRK,'ALBEDO',ALBOLD) + ENDIF +* + IF( IDISP.NE.IDISPO )THEN + CALL XABORT('XELDRV: *HALT* OPTION REQUESTED '// + > ' NO FURTHER CALCULATION IS POSSIBLE') + ELSEIF( IDISP.GT.0 )THEN + IF(INSB.NE.2) REWIND IFTEMP + ELSE + IF( NANGL.NE.NANGLO )THEN + CALL XABORT('XELDRV: NOT POSSIBLE TO CHANGE '// + > ' *NANGL* PARAMETER OF TRACKING FILE') + ENDIF + IF( MXSEG.NE.MXSEGO )THEN + CALL XABORT('XELDRV: NOT POSSIBLE TO CHANGE '// + > ' *MXSEG* PARAMETER OF TRACKING FILE') + ENDIF + IF( MXSUB.NE.MXSUBO )THEN + CALL XABORT('XELDRV: NOT POSSIBLE TO CHANGE '// + > ' *MXSUB* PARAMETER OF TRACKING FILE') + ENDIF + ENDIF +*---- +* 2.2.3) CHECK CONSISTENCY BETWEEN *MODT* FILE AND GEOMETRY BEFORE +* MERGE +*---- + SWCONS=.FALSE. + IF( IDISP.LT.0 )THEN + SWCONS= LELCHK(NSO ,NVO ,VOLOLD,MATOLD,ICOLD, + > NS ,NV ,VOLSUR,MATALB,ICODE, 0) + IF( IPRT.GT.0 )THEN + WRITE(IOUT,'(1H )') + IF( SWCONS )THEN + WRITE(IOUT,'(70H ECHO = >>> CONSISTENCY BETWEEN '// + > 'TRACKING FILE AND UNMERGED GEOMETRY /)') + ELSE + WRITE(IOUT,'(70H ECHO = >>> INCONSISTENCY BETWEEN '// + > 'TRACKING FILE AND UNMERGED GEOMETRY /)') + ENDIF + ENDIF + ENDIF +*---- +* 2.2.4) CHECK CONSISTENCY BETWEEN *OLDT*/*MODT* FILE AND GEOMETRY +* AFTER MERGE +*---- + IF( IDISP.EQ.0.OR.(IDISP.LT.0.AND.(.NOT.SWCONS)) )THEN + IF( NDIMO.NE.NDIM )THEN + CALL XABORT('XELDRV: DIMENSION (2-D/3-D) INCONSISTENCY') + ENDIF + SWCONS= LELCHK(NSO ,NVO ,VOLOLD,MATOLD,ICOLD, + > NSOUT,NREG,VOLMRG,MATMRG,ICODE,IPRT) + IF( SWCONS )THEN + IF( IPRT.GT.0 )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(70H ECHO = >>> CONSISTENCY BETWEEN '// + > 'TRACKING FILE AND MERGED GEOMETRY /)') + ENDIF + ELSE + WRITE(IOUT,'(70H ECHO = >>> INCONSISTENCY BETWEEN '// + > 'TRACKING FILE AND MERGED GEOMETRY /)') + CALL XABORT('XELDRV: INCONSISTENCY OF MERGED GEOMETRY '// + > 'WITH OLD TRACKING FILE ' ) + ENDIF +* +* CONSISTENCY WITH MERGED GEOMETRY +* COPY MERGED VOLUMES INTO VOLSUR ARRAY SINCE MERGE WAS DONE + NS= NSOUT + NV= NREG + IUNK= 0 + DO 50 IR= -NS, NV + VOLSUR(IUNK+1)= VOLOLD(IUNK+1) + MATALB(IUNK+1)= MATOLD(IUNK+1) + KEYMRG(IUNK+1)= IR + IUNK= IUNK+1 + 50 CONTINUE + ENDIF + ENDIF +*---- +* 3) NORMALIZE TEMPORARY FILE FOR *MODT*/*NEWT* FILES ---------------- +*---- + IF((IDISP.NE.0).AND.(INSB.NE.2))THEN +*---- +* 3.1) WARNING IF THE FILE HAS *NTRK*.NE.0 +*---- + IF( NTRK.NE.0 )THEN + WRITE(IOUT,'(1H )') + WRITE(IOUT,'(60H ECHO = >>> WARNING: TRACKING FILE'// + > ' MAY ALREADY BE NORMALIZED /)') + ENDIF + IF (LPRISM) THEN + CALL XELCTR(IFTEMP,IFTRAK,MXSUB,MXSEG,CUTOFX,ALBOLD) + ELSE + CALL XELNTR( NDIM, IFTEMP, IFTRAK, NORE, LMERG, + > IPRT, NS, NV, VOLSUR, MATALB, KEYMRG, + > NSOUT, NREG, VOLMRG, MATMRG, CUTOFX, + > ITGEO, ICODE, ALBOLD, NANGL, MXSUB, + > MXSEG) + ENDIF + IFILE= IFTEMP + IFTEMP= KDRCLS(IFTEMP,2) + IF( IFTEMP.LT.0 ) GO TO 999 + ENDIF +*---- +* 4) CHARGE GEOMETRIC ALBEDOS & GET PHYSICAL ALBEDOS IF NECESSARY ---- +*---- + ICMAX= 0 + DO 60 IR= 1, 6 + ALBEDO(IR)= ONE + IUSED(IR)= 0 + ICMAX= MAX(ICMAX,ICODE(IR)) + IF( ICODE(IR).LT.0 ) ALBEDO(IR)= ALBOLD(-ICODE(IR)) + 60 CONTINUE + IF( ICMAX.GT.0 )THEN + CALL XABORT('XELDRV: PHYSICAL ALBEDOS NOT IMPLEMENTED') + ENDIF + IF( KTOPT .EQ. -1) THEN + KTOPT= ITOPT + ENDIF + IF(KSPEC .EQ. -1 ) THEN + KSPEC= KTOPT + ELSE + KSPEC=MIN(KSPEC,KTOPT) + ENDIF +*---- +* 5) STOCK INFORMATION (OUTPUT TO DRAGON DRIVER) --------------------- +*---- + DO 70 IR= 1, NREG + KEYFLX(IR)= IR + VOLUME(IR)= VOLMRG(IR+NSOUT+1) + MATCOD(IR)= MATMRG(IR+NSOUT+1) + 70 CONTINUE +* +* COMPUTE LEAKAGE SWITCH + LEAKSW=.TRUE. + DO 80 IR= -NSOUT, -1 + IUSED(-MATMRG(IR+NSOUT+1))= 1 + LEAKSW= LEAKSW .AND. ALBEDO(-MATMRG(IR+NSOUT+1)).EQ.ONE + 80 CONTINUE + LEAKSW=.NOT.LEAKSW + DEALLOCATE(MATMRG,VOLMRG) + IF( (IDISP.LE.0).AND.(.NOT.SWNOGE) )THEN + DEALLOCATE(MATOLD,VOLOLD) + ENDIF +* + IF( IPRT.GT.0 )THEN + IF( IPRT.GT.1 )THEN + WRITE(IOUT,'(8H SIDE ,2X,6(7X,A4))') + > (CORIEN(ITGEO,IR),IR=1,6) + WRITE(IOUT,'(8H GEOM #,2X,6(7X,I4.0))') + > (MAX(0,-ICODE(IR)),IR=1,6) + WRITE(IOUT,'(8H PHYS #,2X,6(7X,I4.0))') + > (MAX(0,ICODE(IR)),IR=1,6) + WRITE(IOUT,'(8H ALBEDO,2X,1P,6E11.4)') + > (ALBEDO(IR),IR=1,6) + WRITE(IOUT,'(8H ,2X,6(5X,A6))') + > (CUSED(IUSED(IR)),IR=1,6) + WRITE(IOUT,'(1H )') + ENDIF + WRITE(IOUT,'(1H )') + IF( KSPEC.EQ.0 )THEN + WRITE(IOUT,'(40H ECHO = >>> ISOTROPIC CP CALCULATION )') + ELSEIF( KSPEC.EQ.1 )THEN + WRITE(IOUT,'(40H ECHO = >>> SPECULAR CP CALCULATION )') + IF( CUTOFX.EQ.ZERO )THEN + WRITE(IOUT,'(27H ECHO = >>> NO CUT-OFF )') + ELSE + WRITE(IOUT,'(27H ECHO = >>> MFP. CUT-OFF: ,1P,E11.4 )') + > CUTOFX + ENDIF + ENDIF + WRITE(IOUT,'(28H ECHO = >>> NB. OF REGIONS: ,I5)') NREG + ENDIF +*---- +* 5.2) RELEASE SPACE ACCORDING TO INVERSE ORDER OF ALLOCATIONS +*---- + DEALLOCATE(KEYMRG,MATALB,VOLSUR) +* +* SAVE GENERAL TRACKING INFORMATION. + IF(NANIS.EQ.1) THEN + NUNKNO= NREG + ELSE + IF( NDIM.EQ.1 )THEN + NUNKNO= NANIS*NREG + ELSE IF( NDIM.EQ.2 )THEN + NUNKNO= ((NANIS*(NANIS+1))/2)*NREG + ELSE + NUNKNO= NANIS*NANIS*NREG + ENDIF + ENDIF + CALL LCMGET(IPTRK,'STATE-VECTOR',ISTATE) + ISTATE(1)=NREG + ISTATE(2)=NUNKNO + IF(LEAKSW) THEN + ISTATE(3)=0 + ELSE + ISTATE(3)=1 + ENDIF + IR=0 + DO 100 I=1,NREG + IR=MAX(IR,MATCOD(I)) + 100 CONTINUE + ISTATE(4)=IR + ISTATE(5)=NSOUT + ISTATE(6)=NANIS + ISTATE(7)=ITROP + ISTATE(8)=NORE + ISTATE(9)=KTOPT + ISTATE(10)=KSPEC + ISTATE(13)=LCACT + ISTATE(14)=NMU + ISTATE(16)=NDIM + ISTATE(22)=INSB + ISTATE(27)=NBATCH + ISTATE(39)=NPRISM + IF(LBIHET) ISTATE(40)=1 + CALL LCMPUT(IPTRK,'STATE-VECTOR',NSTATE,1,ISTATE) + CALL LCMPUT(IPTRK,'MATCOD',NREG,1,MATCOD) + CALL LCMPUT(IPTRK,'VOLUME',NREG,2,VOLUME) + CALL LCMPUT(IPTRK,'KEYFLX',NREG,1,KEYFLX) + CALL LCMPUT(IPTRK,'ICODE',6,1,ICODE) + CALL LCMPUT(IPTRK,'ALBEDO',6,2,ALBEDO) + CALL LCMGET(IPTRK,'EXCELTRACKOP',EXTKOP) + EXTKOP(39)=FRTM + EXTKOP(40)=DELU + CALL LCMPUT(IPTRK,'EXCELTRACKOP',NSTATE,2,EXTKOP) + IF(IPRT.GE.1) THEN + WRITE(IOUT,6000) IPRT,(ISTATE(IR),IR=1,12),ISTATE(22), + > ISTATE(16),ISTATE(27),ISTATE(39),ISTATE(40) + WRITE(IOUT,6001)(EXTKOP(IR),IR=1,3) + ENDIF +*---- +* SCRATCH STORAGE DEALLOCATION +*---- + DEALLOCATE(VOLUME) + DEALLOCATE(KEYFLX,MATCOD) + RETURN +* + 6000 FORMAT(' EXCELT PRINT LEVEL =',I8/ + > ' TRACK STATE-VECTOR'/' ------------------'/ + > ' NREG =',I8,' (NUMBER OF REGIONS)'/ + > ' NUNKNO =',I8,' (NUMBER OF UNKNOWNS IN SYSTEM)'/ + > ' ILEAK =',I8,' (LEAKAGE FLAG:0=PRESENT/1=ABSENT)'/ + > ' MAXMIX =',I8,' (NUMBER OF MIXTURES)'/ + > ' NSOUT =',I8,' (NUMBER OF OUTER SURFACES)'/ + > ' NANIS =',I8,' (FLUX ANISOTROPY ORDER)'/ + > ' ITROP =',I8,' (GEOMETRY TYPE)'/ + > ' NORE =',I8,' (TRACK NORMALIZATION OPTION)'/ + > ' KTOPT =',I8,' (TYPE OF TRACKING:0=TISO/1=TSPC)'/ + > ' KSPEC =',I8,' (TYPE OF BOUNDARY CONDITION)'/ + > ' NANGL =',I8,' (USER-SUPPLIED NUMBER OF TRACKING ANGLES)'/ + > ' ISYMM =',I8,' (USER-SUPPLIED TRACKING SYMMETRY FACTOR)'/ + > ' INSB =',I8,' (TYPE OF VECTORIZATION:0=ONEG/1=ALLG/2=XCLL)'/ + > ' NDIM =',I8,' (NUMBER OF GEOMETRIC DIMENSIONS)'/ + > ' NBATCH =',I8,' (NUMBER OF TRACKS IN EACH OPENMP CORE)'/ + > ' NPRISM =',I8,' (NUMBER OF PLANS IN 3D PRISMATIC GEOMETRIES)'/ + > ' IBIHET =',I8,' (0/1=DOUBLE HETEROGENEITY IS NOT/IS ACTIVE)'/ + > ' -----------------'/) + 6001 FORMAT( + > ' EXCELL TRACK OPTIONS '/ + > ' CUTOFX =',F20.8,' (CUTOFF FOR TRACK LENGTH)'/ + > ' DENS =',F20.8,' (TRACK DENSITY)'/ + > ' PCORN =',F20.8,' (CORNER DUPLICATION DISTANCE)'/ + > ' -----------------'/) + 6002 FORMAT( + > ' RECOMPUTED PARAMETERS '/ + > ' NANGL =',I10 ,' (NUMBER OF TRACKING ANGLES)'/ + > ' ISYMM =',I10 ,' (TRACKING SYMMETRY FACTOR)'/ + > ' CUTOFX =',F10.5,' (CUTOFF FOR TRACK LENGTH)'/ + > ' DENS =',F10.5,' (TRACK DENSITY)'/ + > ' PCORN =',F10.5,' (CORNER DUPLICATION DISTANCE)'/ + > ' -----------------'/) +* + 997 WRITE(IOUT,'(31H ERROR= RECORD DESTROYED... )') + WRITE(IOUT,'(31H ERROR= UNABLE TO READ RECORD ,I10)') IREC + WRITE(IOUT,'(31H ERROR= ON FILE FT,I2.2)') IFILE + CALL XABORT('XELDRV: READ TRACKING FILE FAILED' ) + 998 WRITE(IOUT,'(31H ECHO = UNABLE TO OPEN FILE FT,I4)') IFILE + CALL XABORT('XELDRV: OPEN FAILED') + 999 WRITE(IOUT,'(31H ECHO = UNABLE TO CLOSE FILE FT,I4)') IFILE + CALL XABORT('XELDRV: CLOSE FAILED') +* + END |