summaryrefslogtreecommitdiff
path: root/Dragon/src/MESHST.f
diff options
context:
space:
mode:
authorstainer_t <thomas.stainer@oecd-nea.org>2025-09-08 13:48:49 +0200
committerstainer_t <thomas.stainer@oecd-nea.org>2025-09-08 13:48:49 +0200
commit7dfcc480ba1e19bd3232349fc733caef94034292 (patch)
tree03ee104eb8846d5cc1a981d267687a729185d3f3 /Dragon/src/MESHST.f
Initial commit from Polytechnique Montreal
Diffstat (limited to 'Dragon/src/MESHST.f')
-rw-r--r--Dragon/src/MESHST.f1924
1 files changed, 1924 insertions, 0 deletions
diff --git a/Dragon/src/MESHST.f b/Dragon/src/MESHST.f
new file mode 100644
index 0000000..b0d9c76
--- /dev/null
+++ b/Dragon/src/MESHST.f
@@ -0,0 +1,1924 @@
+*DECK MESHST
+ SUBROUTINE MESHST(IPTRK,IPGEOM,REMESH,FVOL,STAIRS,FACST,NCEL,
+ > IPLANZ,ISTATE,NCYL,NSECT,NCPHY,VOLSUR,MATALB,SIDE,NCOUR,
+ > NSMIN,NSMAX,NS,FACB,NVOL,SURB,VSYM,SSYM,IHEX,LXI,NV,MCODE,
+ > SURL,IPLANI,VLAT,ZMIN)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* General numbering of hexagonal assembly.
+*
+*Copyright:
+* Copyright (C) 1991 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): M. Ouisloumen
+*
+*Parameters: input
+* MCODE =1 for Z- symmetry; =2 for Z+ symmetry; =0 otherwise.
+*
+*Parameters: input/output
+* REMESH coordinates of geometry.
+* FVOL first zone number.
+* NVOL first volume number.
+* STAIRS see TRKHEX.
+* FACST see TRKHEX.
+* NCEL number of cells.
+* NSECT number of sectors in region.
+* NCYL number of cylinders in cell.
+* NCPHY number of physical cells.
+* VOLSUR volumes and external surfaces
+* MATALB material albedo vector.
+* FACB first face number.
+* SURB first cell number.
+* VSYM initial geometry volumes.
+* SSYM initial geometry surfaces.
+* IPTRK undefined.
+* IPGEOM undefined.
+* IPLANZ undefined.
+* ISTATE undefined.
+* SIDE undefined.
+* NCOUR undefined.
+* NSMIN undefined.
+* NSMAX undefined.
+* NS undefined.
+* IHEX undefined.
+* LXI undefined.
+* NV undefined.
+* SURL undefined.
+* IPLANI undefined.
+* VLAT undefined.
+* ZMIN undefined.
+*
+*-----------------------------------------------------------------------
+*
+ USE GANLIB
+ IMPLICIT NONE
+ INTEGER NSTATE
+ REAL PI,SQRT3
+ PARAMETER (NSTATE=40)
+ PARAMETER (PI=3.141592653589793,SQRT3=1.732050807568877)
+ TYPE(C_PTR) IPTRK,IPGEOM
+ INTEGER NCEL,IPLANZ,NCPHY,NCOUR,IHEX,LXI,NV,MCODE,IPLANI
+ INTEGER FVOL(NCEL),STAIRS(IPLANZ),FACST(IPLANZ),
+ > ISTATE(NSTATE),MATALB(*),NVOL(*),NSMIN,NSMAX,NS,
+ > NSECT(*),NCYL(NCEL),FACB(*),SURB(*),
+ > VSYM(*),SSYM(*),SURL(*),VLAT(*)
+ REAL REMESH(*),VOLSUR(*),SIDE,ZMIN
+*----
+* LOCAL VARIABLES
+*----
+ CHARACTER TEXT12*12
+ LOGICAL LGCELL,L1CELL,LGSS,LGTURN,LG3D,LGPASS,LSPLIT,LGMERG
+ REAL POIDSH
+ INTEGER IFONC,IFCOUR,N,L
+ INTEGER NEIGHB
+ INTEGER LLL,KSS,LX,LZ,ISTAT9,NDIM,LZZ,ILENT,ITP,ICEL2,
+ > I,ICEL0,NCOUS,ICOU,KCEL,LCEL,ILENZ,IAZ,K,IAUX,
+ > ISURFP,ISURF,ISAUX,JSUR,ISF,IPOINT,KREG,KSURF1,
+ > KSURF2,NSURF1,NSURF2,ISUR,ITC,ILENR,MDR,IOFS,
+ > NRAY,ILENSP,MADD,J,ISEC,LSECT,MIXF,
+ > IFVOL,NZONE,MVOL,JVOL,IVOL,ISURB,JSURB,IST,IY,KZAUX,
+ > NAUX,MIXX,JSP,KBB,JJ,IV,IS,ILENS,ITS,IC,KMIX,NMIX,
+ > IXZPL,KXI,NXI,LFF,LZF,ISTO,ISS1,IMERMX,ISZ,
+ > IFRT,IMER0,IMER1,ISX,IMERG,JMERG,MMCYL,IZON,IFF,
+ > ILENM,ISS,ICEL
+ INTEGER JSECT,LL,IZZ,KY,IMMS,IBSS,IFR0,IXX,ICCOIN,KCCOIN,
+ > MROT,NCPER,ISURSY,MSMAX,ISSXX,IPPZ,IPP1,IXP,JCCOIN,
+ > JP,MXI,IP,ISURB6,ITT9,ISURSX,KSURBX,K1,ICX,ICY,ICZ,
+ > IDEBX,NBASE,ICELC0,ICELC1,NCC,MCYL,NZONE1,IA,
+ > NSECTO,IV1,JVT,IVTURN,ITURN,KAUX,KVOL1,KVOL2,
+ > KSECTX,NZZ,ICXX,ICELC,ICLIM,IXX0,ISS0,JSS0,M,ISS2,
+ > IJSUR,KKB,IXV,LFROT,IVFIN,IVORIN,IVMIN,IVSYM,NZON,
+ > IVAUX,IVMAX,IVOR,IVV,IVSYM0,IVV1,KVV,KVOR,ISY,MSAUX,
+ > IVLMAX,NSAUX,IPPX,ISYAUX,LSMAX,LSPLZM,IDDX,KX2,KSECT
+ INTEGER KX1,KXP,IDEB,IYAUX,II,KSAUX,IVLAT,JTX,IX1,JX,IFR,IW,
+ > JW,MSUR,MCPHY,ISYX,LSPLZP
+ REAL VEX,X,Y,XM,YM,XP,YP,YPP,ZAUX,ZBUX,Z,SURF,R1,R2,PAS,
+ > VOLUM1,VOLUM2,R,VOLUME,VOLUMS,VCYL,SAUX,XTAN,SAUX1
+*----
+* ALLOCATABLE ARRAYS
+*----
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: VTURN,PHTURN,VOL1,ISECT,MXX,
+ + IMX,IMX2,ISSS,IMIX,IPSECT,ICC,ICELL,KNUM,NUMG,ITRN,ISPZ,KVOL,IBB,
+ + ITT,IAA
+ INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISXY
+ REAL, ALLOCATABLE, DIMENSION(:) :: ZZZ,RAY,KRAY,RR
+ TYPE PP
+ REAL, POINTER, DIMENSION(:) :: R
+ INTEGER, POINTER, DIMENSION(:) :: I1,I2
+ END TYPE PP
+ TYPE(PP), ALLOCATABLE, DIMENSION(:) :: IOF
+*----
+* DATA
+*----
+ INTEGER ROT(12)
+ SAVE ROT
+ DATA ROT /2,3,4,5,6,1,6,1,2,3,4,5/
+*
+* STATEMENT FUNCTIONS
+*----
+ IFONC(N,L)= 2+(N-1)*(L+3*(N-2))
+ IFCOUR(N)=NINT( (4.+SQRT(1.+4.*FLOAT(N-1)/3.)
+ + +SQRT(1.+4.*FLOAT(N-2)/3.))*.25)
+*----
+* SCRATCH STORAGE ALLOCATION
+*----
+ ALLOCATE(VOL1(NCPHY),VTURN(NCPHY),PHTURN(NCPHY))
+*
+ LZ=ISTATE(5)
+ LX=ISTATE(3)
+ ISTAT9=ISTATE(9)
+ LGCELL=.FALSE.
+ L1CELL=.FALSE.
+ LGSS=.FALSE.
+ LGTURN=.FALSE.
+ LG3D=.FALSE.
+ IF(ISTATE(8).EQ.1) LGCELL=.TRUE.
+ NDIM=2
+ LZZ=1
+ L1CELL=(LX.EQ.1)
+ IF(LZ.GT.0) THEN
+ NDIM=3
+ LG3D=.TRUE.
+ LZZ=LZ
+ L1CELL=(LX*LZ.EQ.1)
+ ENDIF
+ VEX=1.5*SQRT(3.)*SIDE*SIDE
+ CALL LCMLEN(IPGEOM,'TURN',ILENT,ITP)
+ IF(ILENT.GT.0) LGTURN=.TRUE.
+ NCOUR=1
+ IF(LX.GT.1)NCOUR=IFCOUR(LX)
+*
+* COORDONNEES DES CENTRES DES HEXAGONES
+*
+ X=0.
+ Y=0.
+ XM=0.
+ YM=0.
+ YP=0.
+ XP=0.
+ ICEL=1
+ 18 REMESH(ICEL)=X
+ REMESH(NCEL+ICEL)=Y
+ ICEL2=NEIGHB(ICEL,2,9,LX,POIDSH)
+ IF(ICEL2.GT.LX) GOTO 20
+ ICEL=ICEL2
+ Y=Y+SIDE*SQRT3
+ GO TO 18
+ 20 ICEL=1
+ Y=0
+ 21 ICEL2=NEIGHB(ICEL,5,9,LX,POIDSH)
+ IF(ICEL2.GT.LX) GOTO 22
+ ICEL=ICEL2
+ REMESH(ICEL)=X
+ Y=Y-SIDE*SQRT3
+ REMESH(NCEL+ICEL)=Y
+ GOTO 21
+ 22 CONTINUE
+ DO 30 I=2,NCOUR
+ LGPASS=.FALSE.
+ XP=XP+1.5*SIDE
+ YP=YP+.5*SIDE*SQRT3
+ ICEL=IFONC(I,0)
+ ICEL0=ICEL
+ X=XP
+ Y=YP
+ YPP=YP
+ 23 REMESH(ICEL)=X
+ REMESH(NCEL+ICEL)=Y
+ ICEL2=NEIGHB(ICEL,2,9,LX,POIDSH)
+ IF(ICEL2.GT.LX) GOTO 25
+ Y=Y+SIDE*SQRT3
+ ICEL=ICEL2
+ GO TO 23
+ 25 ICEL=ICEL0
+ Y=YP
+ 26 ICEL2=NEIGHB(ICEL,5,9,LX,POIDSH)
+ IF(ICEL2.GT.LX) GOTO 27
+ Y=Y-SIDE*SQRT3
+ ICEL=ICEL2
+ REMESH(ICEL)=X
+ REMESH(NCEL+ICEL)=Y
+ GOTO 26
+ 27 IF(LGPASS) GOTO 28
+ XM=XM-1.5*SIDE
+ YM=YM+.5*SIDE*SQRT3
+ YPP=YM
+ ICEL=IFONC(I,2)
+ ICEL0=ICEL
+ X=XM
+ Y=YM
+ LGPASS=.TRUE.
+ GO TO 23
+ 28 CONTINUE
+ 30 CONTINUE
+*
+* POUR EVITER DES EFFETS DE DIFFERENCE
+*
+ NCOUS=7
+ DO 31 ICOU=3,NCOUR,2
+ KCEL=IFONC(ICOU,0)+6*ICOU-NCOUS
+ LCEL=KCEL-3*(ICOU-1)
+ REMESH(NCEL+KCEL)=0.
+ REMESH(NCEL+LCEL)=0.
+ NCOUS=NCOUS+1
+ 31 CONTINUE
+ STAIRS(1)=LX
+ IF(LG3D) THEN
+ CALL LCMSIX(IPTRK,'DATA_DUP',1)
+ CALL LCMLEN(IPTRK,'MESHZ',ILENZ,ITP)
+ IF(ILENZ.NE.LZZ+1)CALL XABORT('MESHST: MISSING DIMENSION MESHZ')
+ ALLOCATE(ZZZ(ILENZ))
+ CALL LCMGET(IPTRK,'MESHZ',ZZZ)
+ CALL LCMSIX(IPTRK,' ',2)
+*
+*--- TEST SUR L'ORDONANCE DES PLANS DES CELLULES SUIVANT L'AXE Z
+*
+ ZAUX=ZZZ(1)
+ ZMIN=ZAUX
+ DO 29 IAZ=1,ILENZ-1
+ ZBUX=ZZZ(IAZ+1)
+ IF(ZAUX.GE.ZBUX)CALL XABORT('MESHST: WRONG CELLS PLAN POSITION')
+ ZAUX=ZBUX
+ 29 CONTINUE
+ Z=ZZZ(2)
+ DO 32 K=1,LX
+ REMESH(2*NCEL+K)=Z
+ 32 CONTINUE
+ IAUX=0
+ DO 35 I=2,LZ
+ STAIRS(I)=I*LX
+ Z=ZZZ(I+1)
+ DO 33 K=1,LX
+ IAUX=IAUX+1
+ REMESH(LX+IAUX)=REMESH(K)
+ REMESH(NCEL+LX+IAUX)=REMESH(NCEL+K)
+ REMESH(2*NCEL+LX+IAUX)=Z
+ 33 CONTINUE
+ 35 CONTINUE
+ ENDIF
+*
+* CALCUL DES SURFACES EXTERNES ET AFFECTATION DES ALBEDOS
+*
+ ISURFP=6
+ IF(NCOUR.GT.1)ISURFP=6*(3+2*(NCOUR-2))
+ ISS=1
+ ISURF=NS
+ ISAUX=ISURF
+ IF(LG3D) THEN
+ ISAUX=ISURF-NSMAX
+ ISS=NSMIN+1
+ DO 70 I=1,NSMIN
+ MATALB(I)=-6
+ 70 CONTINUE
+ DO 71 I=1,NSMAX
+ MATALB(ISAUX+I)=-5
+ 71 CONTINUE
+ ENDIF
+ DO 75 I=ISS,ISAUX
+ MATALB(I)=-1
+ 75 CONTINUE
+ JSUR=NS-NSMAX+1
+ DO 80 K=1,LZZ
+ ISF=ISS+ISURFP-1
+ SURF=SIDE
+ FACST(K)=ISF
+ ISS=ISF+1
+ 80 CONTINUE
+ IPOINT=2*NCEL
+ IF(LG3D) THEN
+ IPOINT=3*NCEL
+ ENDIF
+*
+ KREG=ISURF+1
+ VOLSUR(KREG)=0.
+ MATALB(KREG)=0
+ KSURF1=0
+ KSURF2=ISAUX
+ NSURF1=NSMIN+1
+ NSURF2=NS+1
+ ISUR=0
+ Z=0.0
+ KSECT=0
+ IF(L1CELL) THEN
+*
+* CAS D'UNE SEULE CELLULE
+*
+ CALL LCMLEN(IPGEOM,'SECTOR',ILENS,ITC)
+ CALL LCMLEN(IPGEOM,'RADIUS',ILENR,ITP)
+ MDR=ILENR
+ IF(ILENR.EQ.0) MDR=1
+ ALLOCATE(ISECT(MDR),MXX(MDR))
+ CALL LCMLEN(IPGEOM,'MIX',ILENM,ITP)
+ IF(ILENS.GT.0) THEN
+ IF(ILENS.NE.MDR) CALL XABORT('MESHST: INCONSISTENT LENGTHS(1'
+ + //').')
+ CALL LCMGET(IPGEOM,'SECTOR',ISECT)
+ K=0
+ DO J=1,MDR
+ K=K+6*(ISECT(J)-1)
+ ENDDO
+ IF(K.NE.ILENM) THEN
+ CALL XABORT('MESHST: SECTOR-DEFINED MIX INDICES EXPECTED(1'
+ + //').')
+ ENDIF
+ ALLOCATE(IMX2(ILENM))
+ CALL LCMGET(IPGEOM,'MIX',IMX2)
+ IOFS=0
+ DO J=1,MDR
+ IOFS=IOFS+1
+ MXX(J)=IMX2(IOFS)
+ DO K=2,6*(ISECT(J)-1)
+ IOFS=IOFS+1
+ IF(IMX2(IOFS).NE.MXX(J)) THEN
+ CALL XABORT('MESHST: SECTOR-DEPENDENT MIX NOT IM'
+ + //'PLEMENTED(1).')
+ ENDIF
+ ENDDO
+ ENDDO
+ DEALLOCATE(IMX2)
+ ELSE
+ IF(ILENM.NE.MDR) CALL XABORT('MESHST: INCONSISTENT LENGTHS(2'
+ + //').')
+ CALL LCMGET(IPGEOM,'MIX',MXX)
+ ISECT(:MDR)=1
+ ENDIF
+ IF(ILENR.GT.0) THEN
+ ALLOCATE(RAY(ILENR))
+ CALL LCMGET(IPGEOM,'RADIUS',RAY)
+ CALL LCMLEN(IPGEOM,'SPLITR',ILENSP,ITP)
+ IF(ILENSP.GT.0) THEN
+ IF(ITP.NE.1.OR.ILENSP.NE.ILENR-1)
+ + CALL XABORT('MESHST: '//
+ + 'MISSING TYPE OR DIMENSION OF SPLITR')
+ ALLOCATE(ISSS(ILENSP))
+ CALL LCMGET(IPGEOM,'SPLITR',ISSS)
+ NRAY=0
+ DO 101 I=1,ILENSP
+ NRAY=NRAY+ABS(ISSS(I))
+ 101 CONTINUE
+ ALLOCATE(KRAY(NRAY+1),IMIX(NRAY+1),IPSECT(NRAY+1))
+ R1=0.0
+ MADD=-1
+ KRAY(1)=0.0
+ DO 103 J=1,ILENSP
+ ISEC=ISSS(J)
+ LSECT=ISECT(J)
+ MIXF=MXX(J)
+ IF(ISEC.EQ.0)CALL XABORT('MESHST: INVALID SPLITR')
+ IF(ISEC.GT.0) THEN
+ R2=RAY(J+1)
+ PAS=(R2-R1)/FLOAT(ISEC)
+ DO 111 K=1,ISEC
+ MADD=MADD+1
+ KRAY(MADD+2)=R1+PAS*FLOAT(K)
+ IMIX(MADD+1)=MIXF
+ IPSECT(MADD+1)=LSECT
+ 111 CONTINUE
+ R1=R2
+ ELSE
+ R2=RAY(J+1)
+ R1=R1**2
+ R2=R2**2
+ PAS=(R2-R1)/FLOAT(-ISEC)
+ DO 112 K=1,-ISEC
+ MADD=MADD+1
+ KRAY(MADD+2)=SQRT(R1+PAS*FLOAT(K))
+ IMIX(MADD+1)=MIXF
+ IPSECT(MADD+1)=LSECT
+ 112 CONTINUE
+ R1=SQRT(R2)
+ ENDIF
+ 103 CONTINUE
+ IMIX(NRAY+1)=MXX(ILENR)
+ IPSECT(NRAY+1)=ISECT(ILENR)
+ DEALLOCATE(MXX,ISSS,ISECT)
+ ALLOCATE(ISECT(NRAY+1))
+ DO 104 J=1,NRAY+1
+ ISECT(J)=IPSECT(J)
+ 104 CONTINUE
+ DEALLOCATE(IPSECT)
+ ELSE
+ NRAY=ILENR-1
+ ALLOCATE(IMIX(NRAY+1),KRAY(NRAY+1))
+ DO 105 J=1,NRAY+1
+ IMIX(J)=MXX(J)
+ KRAY(J)=RAY(J)
+ 105 CONTINUE
+ ENDIF
+ DEALLOCATE(MXX,RAY)
+ ELSE
+ ALLOCATE(IMIX(MDR))
+ DO 106 J=1,MDR
+ IMIX(J)=MXX(J)
+ 106 CONTINUE
+ DEALLOCATE(MXX)
+ NRAY=0
+ ENDIF
+ IAUX=2
+ IF(LG3D)IAUX=3*NCEL
+ IFVOL=0
+ NZONE=NRAY+1
+ MVOL=0
+ JVOL=1
+ IVOL=0
+ ISURB=NSMIN
+ JSURB=0
+ DO 119 I=1,NCEL
+ NVOL(I)=JVOL
+ IF(LG3D) THEN
+ Z=REMESH(2*NCEL+I)
+ IF(I.GT.STAIRS(1)) THEN
+ IST=1
+ DO 129 IY=2,LZZ
+ IF(I.LE.STAIRS(IY)) THEN
+ IST=IY-1
+ GOTO 139
+ ENDIF
+ 129 CONTINUE
+ 139 KZAUX=I-STAIRS(IST)
+ IF(IST.GT.1)KZAUX=KZAUX+STAIRS(IST-1)
+ Z=Z-REMESH(2*NCEL+KZAUX)
+ ENDIF
+ ENDIF
+ NCYL(I)=NRAY
+ FVOL(I)=IFVOL+1
+ IFVOL=IFVOL+NZONE
+ DO 117 J=1,NRAY
+ IAUX=IAUX+1
+ REMESH(IAUX)=KRAY(J+1)
+ 117 CONTINUE
+ VOLUM1=0.
+ IF(LG3D) THEN
+ IF(IPLANZ.GT.1) THEN
+ IF(I.LE.STAIRS(1)) THEN
+ FACB(I)=KSURF1
+ ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN
+ ISUR=ISUR+1
+ FACB(LX+ISUR)=KSURF2
+ ENDIF
+ ELSE
+ FACB(I)=KSURF1
+ FACB(LX+I)=KSURF2
+ ENDIF
+ ENDIF
+ NAUX=0
+ DO 120 J=1,NRAY+1
+ MVOL=MVOL+1
+ KSECT=ISECT(J)
+ NSECT(MVOL)=KSECT
+ NAUX=1
+ IF(KSECT.GT.1) NAUX=6*(KSECT-1)
+ IVOL=IVOL+NAUX
+ MIXX=IMIX(J)
+ KREG=KREG+1
+ IF(J.EQ.NZONE) THEN
+ VOLUM2=VEX
+ ELSE
+ R=KRAY(J+1)
+ VOLUM2=PI*R*R
+ ENDIF
+ VOLUME=(VOLUM2-VOLUM1)/REAL(NAUX)
+ VOLUMS=0.0
+ IF(LG3D) THEN
+ VOLUMS=VOLUME*.25
+*
+* SURFACES SUPERIEURES ET INFERIEURES (SELON L'AXE Z)
+*
+ IF(IPLANZ.GT.1) THEN
+ IF(I.LE.STAIRS(1)) THEN
+ KSURF1=KSURF1+1
+ NSURF1=NSURF1-1
+ VOLSUR(NSURF1)=VOLUMS
+ ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN
+ KSURF2=KSURF2+1
+ NSURF2=NSURF2-1
+ VOLSUR(NSURF2)=VOLUMS
+ ENDIF
+ ELSE
+ KSURF1=KSURF1+1
+ NSURF1=NSURF1-1
+ VOLSUR(NSURF1)=VOLUMS
+ KSURF2=KSURF2+1
+ NSURF2=NSURF2-1
+ VOLSUR(NSURF2)=VOLUMS
+ ENDIF
+ VOLUME=VOLUME*Z
+ ENDIF
+ VOLUM1=VOLUM2
+ VOLSUR(KREG)=VOLUME
+ MATALB(KREG)=MIXX
+ DO 121 K=2,NAUX
+ KREG=KREG+1
+ VOLSUR(KREG)=VOLUME
+ MATALB(KREG)=MIXX
+ IF(LG3D) THEN
+ IF(IPLANZ.GT.1) THEN
+ IF(I.LE.STAIRS(1)) THEN
+ KSURF1=KSURF1+1
+ NSURF1=NSURF1-1
+ VOLSUR(NSURF1)=VOLUMS
+ ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN
+ KSURF2=KSURF2+1
+ NSURF2=NSURF2-1
+ VOLSUR(NSURF2)=VOLUMS
+ ENDIF
+ ELSE
+ KSURF1=KSURF1+1
+ NSURF1=NSURF1-1
+ VOLSUR(NSURF1)=VOLUMS
+ KSURF2=KSURF2+1
+ NSURF2=NSURF2-1
+ VOLSUR(NSURF2)=VOLUMS
+ ENDIF
+ ENDIF
+ 121 CONTINUE
+ JVOL=IVOL+1
+ 120 CONTINUE
+ SURF=SIDE
+ JSP=6
+ KBB=1
+ IF(KSECT.GT.1) THEN
+ SURF=SIDE/(KSECT-1)
+ JSP=NAUX
+ KBB=KSECT-1
+ ENDIF
+ IF(LG3D)SURF=SURF*Z
+ DO 118 JJ=1,JSP
+ JSUR=JSUR-1
+ VOLSUR(JSUR)=.25*SURF
+ 118 CONTINUE
+ DO 122 JJ=1,6
+ JSURB=JSURB+1
+ SURB(JSURB)=ISURB
+ ISURB=ISURB+KBB
+ 122 CONTINUE
+ 119 CONTINUE
+ DEALLOCATE(IMIX,ISECT)
+ IF(LG3D) DEALLOCATE(ZZZ)
+ IF(NRAY.GT.0) DEALLOCATE(KRAY)
+ DO 715 IV=1,NV
+ VSYM(IV)=IV
+ 715 CONTINUE
+ DO 716 IS=1,NS
+ SSYM(IS)=IS
+ 716 CONTINUE
+ GO TO 800
+ ENDIF
+* CAS D'UN ASSEMBLAGE DE CELLULE
+*
+ IPP1=0
+ MROT=0
+ MSMAX=0
+ ALLOCATE(ISXY(6,MAX(IPLANZ,IPLANI)))
+ IF(LGCELL) THEN
+*
+* SPLITING DES RAYONS ET DEFINITION DES SECTEURS POUR
+* LES CELLULES GENERATRICES
+*
+ ALLOCATE(IOF(ISTAT9),ICC(ISTAT9),ICELL(3*ISTAT9))
+ CALL LCMGET(IPGEOM,'CELL',ICELL)
+ DO 10 I=1,ISTAT9
+ WRITE(TEXT12(1:4),'(A4)') ICELL(3*I-2)
+ WRITE(TEXT12(5:8),'(A4)') ICELL(3*I-1)
+ WRITE(TEXT12(9:12),'(A4)') ICELL(3*I)
+ CALL LCMSIX(IPGEOM,TEXT12,1)
+ CALL LCMLEN(IPGEOM,'RADIUS',ILENR,ITP)
+ CALL LCMLEN(IPGEOM,'SECTOR',ILENS,ITS)
+ IF(ILENR.GT.0) THEN
+ ALLOCATE(ISECT(ILENR),IMX(ILENR))
+ CALL LCMLEN(IPGEOM,'MIX',ILENM,ITP)
+ IF(ILENS.GT.0) THEN
+ IF(ILENS.NE.ILENR) CALL XABORT('MESHST: INCONSISTENT L'
+ + //'ENGTHS(3).')
+ CALL LCMGET(IPGEOM,'SECTOR',ISECT)
+ K=0
+ DO J=1,ILENR
+ K=K+6*(ISECT(J)-1)
+ ENDDO
+ IF(K.NE.ILENM) THEN
+ CALL XABORT('MESHST: SECTOR-DEFINED MIX INDICES EXPE'
+ + //'CTED(2).')
+ ENDIF
+ ALLOCATE(IMX2(ILENM))
+ CALL LCMGET(IPGEOM,'MIX',IMX2)
+ IOFS=0
+ DO J=1,ILENR
+ IOFS=IOFS+1
+ IMX(J)=IMX2(IOFS)
+ DO K=2,6*(ISECT(J)-1)
+ IOFS=IOFS+1
+ IF(IMX2(IOFS).NE.IMX(J)) THEN
+ CALL XABORT('MESHST: SECTOR-DEPENDENT MIX NOT IM'
+ + //'PLEMENTED(2).')
+ ENDIF
+ ENDDO
+ ENDDO
+ DEALLOCATE(IMX2)
+ ELSE
+ IF(ILENM.NE.ILENR) CALL XABORT('MESHST: INCONSISTENT L'
+ + //'ENGTHS(4).')
+ ISECT(:ILENR)=1
+ CALL LCMGET(IPGEOM,'MIX',IMX)
+ ENDIF
+ CALL LCMLEN(IPGEOM,'SPLITR',ILENSP,ITP)
+ IF(ILENSP.GT.0) THEN
+ IF(ITP.NE.1.OR.ILENSP.NE.ILENR-1)
+ + CALL XABORT('MESHST: '//
+ + 'MISSING TYPE OR DIMENSION OF SPLITR')
+ ALLOCATE(RR(ILENR))
+ CALL LCMGET(IPGEOM,'RADIUS',RR)
+ ALLOCATE(ISSS(ILENSP))
+ CALL LCMGET(IPGEOM,'SPLITR',ISSS)
+ NRAY=1
+ DO 5 J=1,ILENSP
+ NRAY=NRAY+ABS(ISSS(J))
+ 5 CONTINUE
+ ALLOCATE(IOF(I)%R(NRAY),IOF(I)%I1(NRAY),IOF(I)%I2(NRAY))
+ KMIX=0
+ DO 7 J=1,ILENR-1
+ NMIX=IMX(J)
+ ISEC=ISSS(J)
+ LSECT=ISECT(J)
+ IF(ISEC.EQ.0)CALL XABORT('MESHST: INVALID SPLITR')
+ DO 6 L=1,ABS(ISEC)
+ IOF(I)%I1(KMIX+1)=NMIX
+ IOF(I)%I2(KMIX+1)=LSECT
+ KMIX=KMIX+1
+ 6 CONTINUE
+ 7 CONTINUE
+ IOF(I)%I1(KMIX+1)=IMX(ILENR)
+ IOF(I)%I2(KMIX+1)=ISECT(ILENR)
+ IOF(I)%R(1)=0.0
+ R1=0.
+ IAUX=0
+ DO 109 K=1,ILENSP
+ ISEC=ISSS(K)
+ IF(ISEC.EQ.0)CALLXABORT('MESHST: INVALID SPLITR')
+ IF(ISEC.GT.0) THEN
+ R2=RR(K+1)
+ PAS=(R2-R1)/FLOAT(ISEC)
+ DO 8 L=1,ISEC
+ IAUX=IAUX+1
+ IOF(I)%R(IAUX+1)=R1+PAS*REAL(L)
+ 8 CONTINUE
+ R1=R2
+ ELSE
+ R2=RR(K+1)
+ R1=R1**2
+ R2=R2**2
+ PAS=(R2-R1)/FLOAT(-ISEC)
+ DO 108 L=1,-ISEC
+ IAUX=IAUX+1
+ IOF(I)%R(IAUX+1)=SQRT(R1+PAS*REAL(L))
+ 108 CONTINUE
+ R1=SQRT(R2)
+ ENDIF
+ 109 CONTINUE
+ DEALLOCATE(ISSS,RR)
+ ICC(I)=NRAY-1
+ ELSE
+ ICC(I)=ILENR-1
+ ALLOCATE(IOF(I)%R(ILENR))
+ CALL LCMGET(IPGEOM,'RADIUS',IOF(I)%R)
+ ALLOCATE(IOF(I)%I1(ILENR),IOF(I)%I2(ILENR))
+ DO 9 J=1,ILENR
+ IOF(I)%I1(J)=IMX(J)
+ IOF(I)%I2(J)=ISECT(J)
+ 9 CONTINUE
+ ENDIF
+ DEALLOCATE(IMX,ISECT)
+ ELSE
+ ICC(I)=0
+ ALLOCATE(IOF(I)%I1(1),IOF(I)%I2(1))
+ CALL LCMLEN(IPGEOM,'MIX',ILENM,ITP)
+ IF(ILENS.GT.0) THEN
+ CALL LCMGET(IPGEOM,'SECTOR',IOF(I)%I2(1))
+ IF(6*(IOF(I)%I2(1)-1).NE.ILENM) THEN
+ CALL XABORT('MESHST: SECTOR-DEFINED MIX INDICES EXPE'
+ + //'CTED(3).')
+ ENDIF
+ ALLOCATE(IMX2(ILENM))
+ CALL LCMGET(IPGEOM,'MIX',IMX2)
+ DO K=2,6*(IOF(I)%I2(1)-1)
+ IF(IMX2(K).NE.IMX2(1)) THEN
+ CALL XABORT('MESHST: SECTOR-DEPENDENT MIX NOT IMPL'
+ + //'EMENTED(3).')
+ ENDIF
+ ENDDO
+ IOF(I)%I1(1)=IMX2(1)
+ DEALLOCATE(IMX2)
+ ELSE
+ IF(ILENM.NE.1) CALL XABORT('MESHST: INCONSISTENT LENGT'
+ + //'HS(5).')
+ CALL LCMGET(IPGEOM,'MIX',IOF(I)%I1(1))
+ IOF(I)%I2(1)=1
+ ENDIF
+ ENDIF
+ IF(ILENS.EQ.0) THEN
+ IF(LGTURN)CALL XABORT('MESHST: SECTOR MUST BE DEFINED '//
+ + 'OR CANCEL TURN ')
+ ENDIF
+ CALL LCMSIX(IPGEOM,' ',2)
+ 10 CONTINUE
+*--- NUMEROTATION DES VOLUMES DE LA SYMETRIE D'ENTREE
+ IXZPL=IPLANZ
+ IF(MCODE.GT.0)IXZPL=IPLANI
+ KXI=LXI*IXZPL
+ NXI=KXI
+ IF(IHEX.LE.9) THEN
+ CALL LCMSIX(IPTRK,'DATA_DUP',1)
+ CALL LCMLEN(IPTRK,'SPLITZD',LFF,KSS)
+ CALL LCMSIX(IPTRK,' ',2)
+ LSPLIT=.FALSE.
+ LZF=IXZPL
+ IF(LFF.GT.0) THEN
+ LZF=LFF
+ NXI=LXI*LZF
+ LSPLIT=.TRUE.
+ ENDIF
+ ALLOCATE(KNUM(2*NXI),NUMG(NXI))
+ CALL LCMLEN(IPGEOM,'MERGE',LLL,KSS)
+ LGMERG=.FALSE.
+ IF(LLL.GT.0) THEN
+ CALL LCMGET(IPGEOM,'MERGE',KNUM)
+ LGMERG=.TRUE.
+ CALL LCMGET(IPGEOM,'MIX',NUMG)
+ DO I=1,NXI
+ NUMG(I)=-NUMG(I)
+ ENDDO
+ ELSE
+ CALL LCMGET(IPGEOM,'MIX',KNUM)
+ DO I=1,NXI
+ KNUM(I)=-KNUM(I)
+ NUMG(I)=KNUM(I)
+ ENDDO
+ ENDIF
+ IF(LGTURN) THEN
+ CALL LCMGET(IPGEOM,'TURN',KNUM(NXI+1))
+ ELSE
+ KNUM(NXI+1:2*NXI)=1
+ LGTURN=.TRUE.
+ ENDIF
+ IVOL=0
+ ISTO=0
+ ALLOCATE(ITRN(KXI*3),ISPZ(LZF))
+ IF(LSPLIT) THEN
+ CALL LCMSIX(IPTRK,'DATA_DUP',1)
+ CALL LCMGET(IPTRK,'SPLITZD',ISPZ)
+ CALL LCMSIX(IPTRK,' ',2)
+ ELSE
+ ISPZ(:LZF)=1
+ ENDIF
+ ALLOCATE(KVOL(KXI))
+ ISS=-1
+ ISS1=-1
+ IMERMX=0
+ DO 182 ISZ=1,LZF
+ IFRT=ISS1
+ IMER0=KNUM(LXI*ISZ)
+ IMER1=IMER0
+ DO 482 ISX=1,LXI
+ ISS=ISS+1
+ ISS1=ISS1+1
+ IMERG=KNUM(ISS1+1)
+ JMERG=NUMG(ISS1+1)
+ MMCYL=ICC(JMERG)
+ IF(LSPLIT) THEN
+ IMER0=MAX(IMER0,IMERG)
+ IMER1=MIN(IMER1,IMERG)
+ ENDIF
+ IZON=0
+ IZZ=0
+ LL=0
+ DO 171 IFF=1,MMCYL+1
+ JSECT=IOF(JMERG)%I2(IFF)
+ IF(JSECT.GT.1) THEN
+ LL=JSECT-1
+ IZZ=6*LL
+ ELSE
+ LL=1
+ IZZ=1
+ ENDIF
+ IZON=IZON+IZZ
+ 171 CONTINUE
+ IMERG=IMERG+IMERMX
+ IF(LGMERG) THEN
+ DO 281 KY=1,ISTO
+ IF(IMERG.EQ.ITRN(KXI+KY)) THEN
+ IMMS=ITRN(2*KXI+KY)
+ IBSS=KVOL(IMMS+1)
+ KVOL(ISS+1)=IBSS
+ ITRN(ISS+1)=ITRN(IMMS+1)
+ GOTO 381
+ ENDIF
+ 281 CONTINUE
+ ENDIF
+ ITRN(KXI+ISTO+1)=IMERG
+ ITRN(2*KXI+ISTO+1)=ISS
+ ISTO=ISTO+1
+ KVOL(ISS+1)=IVOL+1
+ IVOL=IVOL+IZON
+ ITRN(ISS+1)=IVOL-IZZ+LL*ROT(KNUM(NXI+ISS1+1))
+ 381 CONTINUE
+ 482 CONTINUE
+ IF(LSPLIT) THEN
+ IFR0=IFRT
+ DO 582 IXX=1,ISPZ(ISZ)-1
+ IMERMX=IMERMX+IMER0-IMER1+1
+ IFRT=IFR0
+ DO 682 ISX=1,LXI
+ ISS=ISS+1
+ IFRT=IFRT+1
+ IMERG=KNUM(IFRT+1)
+ JMERG=NUMG(IFRT+1)
+ MMCYL=ICC(JMERG)
+ IZON=0
+ IZZ=0
+ LL=0
+ DO 671 IFF=1,MMCYL+1
+ JSECT=IOF(JMERG)%I2(IFF)
+ IF(JSECT.GT.1) THEN
+ LL=JSECT-1
+ IZZ=6*LL
+ ELSE
+ LL=1
+ IZZ=1
+ ENDIF
+ IZON=IZON+IZZ
+ 671 CONTINUE
+ IMERG=IMERG+IMERMX
+ IF(LGMERG) THEN
+ DO 681 KY=1,ISTO
+ IF(IMERG.EQ.ITRN(KXI+KY)) THEN
+ IMMS=ITRN(2*KXI+KY)
+ IBSS=KVOL(IMMS+1)
+ KVOL(ISS+1)=IBSS
+ ITRN(ISS+1)=ITRN(IMMS+1)
+ GOTO 781
+ ENDIF
+ 681 CONTINUE
+ ENDIF
+ ITRN(KXI+ISTO+1)=IMERG
+ ITRN(2*KXI+ISTO+1)=ISS
+ ISTO=ISTO+1
+ KVOL(ISS+1)=IVOL+1
+ IVOL=IVOL+IZON
+ ITRN(ISS+1)=IVOL-IZZ+LL*ROT(KNUM(NXI+IFRT+1))
+ 781 CONTINUE
+ 682 CONTINUE
+ 582 CONTINUE
+ ENDIF
+ 182 CONTINUE
+*--- RECHERCHE DU NOMBRE DE SURFACES QUE PRESENTE LA SYMETRIE
+ ICCOIN=-1
+ JCCOIN=-1
+ KCCOIN=-1
+ MROT=6
+ NCPER=0
+ IF(IHEX.EQ.1) THEN
+ NCPER=NINT(REAL(NCOUR)/2.)
+ ELSEIF(IHEX.EQ.2) THEN
+ NCPER=NCOUR
+ MROT=3
+ ELSEIF(IHEX.EQ.3) THEN
+ NCPER=2*NINT(REAL(NCOUR)/2.)-1
+ ICCOIN=LXI-NINT(REAL(NCPER)/2.)+1
+ MROT=3
+ ELSEIF(IHEX.EQ.4) THEN
+ NCPER=3*NINT(REAL(NCOUR)/2.)-2
+ IF(MOD(NCOUR,2).EQ.0)NCPER=NCPER+1
+ ICCOIN=LXI-NCPER+NINT(REAL(NCOUR)/2.)
+ MROT=2
+ ELSEIF(IHEX.EQ.5) THEN
+ NCPER=1
+ IF(NCOUR.GT.1)NCPER=2*(NCOUR-1)
+ ICCOIN=LXI-NCPER+NCOUR-1
+ KCCOIN=LXI
+ MROT=3
+ ELSEIF(IHEX.EQ.6) THEN
+ NCPER=1
+ IF(NCOUR.GT.1)NCPER=4+3*(NCOUR-2)-1
+ KCCOIN=LXI-NCPER+NCOUR-1
+ ICCOIN=KCCOIN+NCOUR-1
+ JCCOIN=ICCOIN+NCOUR-1
+ MROT=2
+ ELSEIF(IHEX.EQ.7) THEN
+ NCPER=1
+ IF(NCOUR.GT.1)NCPER=3*NCOUR-2
+ ICCOIN=LXI-NCOUR+1
+ KCCOIN=ICCOIN-NCOUR+1
+ MROT=1
+ ELSEIF(IHEX.EQ.8) THEN
+ NCPER=1
+ IF(NCOUR.GT.1)NCPER=2*(NCOUR+NINT(REAL(NCOUR)/2.))-3
+ JCCOIN=LXI-NINT(REAL(NCOUR)/2.)+1
+ KCCOIN=JCCOIN-NCOUR+1
+ ICCOIN=KCCOIN-NCOUR+1
+ MROT=1
+ ELSEIF(IHEX.EQ.9) THEN
+ MROT=1
+ NCPER=1
+ IF(NCOUR.GT.1) NCPER=6*(NCOUR-1)
+ ICCOIN=IFONC(NCOUR,0)
+ JCCOIN=IFONC(NCOUR,1)
+ KCCOIN=IFONC(NCOUR,2)
+ ELSE
+ CALL XABORT('MESHST: INVALID TYPE OF SYMETRIE ')
+ ENDIF
+ ISURSY=0
+ ISAUX=1
+ MSMAX=0
+ ISSXX=0
+ IPPZ=LZF
+ IPP1=IPLANZ
+ IF(MCODE.GT.0) IPP1=IPLANI
+ ISXY(:6,:IPP1)=0
+ IXP=0
+ DO 500 JP=1,IPPZ
+ MXI=LXI*(JP-1)
+ DO 501 IP=IXP+1,IXP+ISPZ(JP)
+ ISURB6=0
+ ITT9=NUMG(LXI+MXI)
+ ISURSX=IOF(ITT9)%I2(ICC(ITT9)+1)-1
+ KSURBX=ISURSX
+ IF(ISURSX.EQ.0) THEN
+ ISURSX=1
+ KSURBX=1
+ ENDIF
+ JSECT=0
+ DO 183 K1=LXI+MXI,LXI+MXI-NCPER+1,-1
+ K=NUMG(K1)
+ JSECT=IOF(K)%I2(ICC(K)+1)
+ ICX=2
+ IF(IHEX.GT.2) THEN
+ IF(K1.EQ.ICCOIN+MXI)ICX=3
+ IF(K1.EQ.JCCOIN+MXI)ICX=3
+ IF(K1.EQ.KCCOIN+MXI)ICX=3
+ IF(IHEX.EQ.9) THEN
+ IF(K1.EQ.MXI+IFONC(NCOUR,3))ICX=3
+ IF(K1.EQ.MXI+IFONC(NCOUR,4))ICX=3
+ IF(K1.EQ.MXI+IFONC(NCOUR,5))ICX=3
+ ENDIF
+ IF(K1.GE.ICCOIN+MXI) THEN
+ IF(IHEX.LE.4) THEN
+ IF(K1.EQ.MXI+LXI.AND.MOD(NCOUR,2).NE.0) THEN
+ ICY=1
+ IF(IHEX.EQ.4)ICY=2
+ ISURB6=ISURB6+ICY*(JSECT-1)
+ IF(JSECT.EQ.1)ISURB6=ISURB6+ICY
+ IF(IHEX.EQ.3) ICX=1
+ ELSE
+ ISURB6=ISURB6+2*(JSECT-1)
+ IF(JSECT.EQ.1)ISURB6=ISURB6+2
+ ENDIF
+ ELSE
+ ICZ=ICX
+ IF(K1.EQ.ICCOIN+MXI)ICZ=2
+ ISURB6=ISURB6+ICZ*(JSECT-1)
+ IF(JSECT.EQ.1)ISURB6=ISURB6+ICZ
+ ENDIF
+ ENDIF
+ ENDIF
+ IF(JSECT.GT.1) THEN
+ ISURSY=ISURSY+ICX*(JSECT-1)
+ ELSE
+ ISURSY=ISURSY+ICX
+ ENDIF
+ 183 CONTINUE
+ IDEBX=2
+ IF(JSECT.GT.1)IDEBX=JSECT
+ IF(IHEX.EQ.1.OR.IHEX.EQ.3.OR.IHEX.EQ.4.OR.IHEX.EQ.8) THEN
+ IF(MOD(NCOUR,2).NE.0) THEN
+ IF(JSECT.GT.1) THEN
+ ISURSY=ISURSY-JSECT+1
+ ELSE
+ ISURSY=ISURSY-1
+ ENDIF
+ IF(IHEX.EQ.8) THEN
+ ISURSY=ISURSY-ISURSX
+ ISURB6=ISURB6-ISURSX
+ ENDIF
+ ENDIF
+ ENDIF
+ ISXY(1,IP)=ISURSY
+ ISXY(2,IP)=ISURSX
+ ISXY(3,IP)=ISURB6
+ ISXY(4,IP)=IDEBX+ISAUX-1
+ ISXY(5,IP)=KSURBX
+ ISXY(6,IP)=ISAUX
+ ISAUX=ISURSY+1
+ MSMAX=MSMAX+ISURSY-ISSXX
+ ISSXX=ISURSY
+ 501 CONTINUE
+ IXP=IXP+ISPZ(JP)
+ 500 CONTINUE
+ DEALLOCATE(KNUM,NUMG,ISPZ)
+ ENDIF
+ DEALLOCATE(ICELL)
+ NBASE=NCEL+NCEL
+ IF(LGTURN)NBASE=NBASE+NCEL
+ ALLOCATE(IBB(NBASE))
+ CALL LCMSIX(IPTRK,'DATA_DUP',1)
+ CALL LCMGET(IPTRK,'GENERATING',IBB)
+ CALL LCMGET(IPTRK,'MERGE',IBB(NCEL+1))
+ IF(LGTURN)CALL LCMGET(IPTRK,'TURN',IBB(2*NCEL+1))
+ CALL LCMSIX(IPTRK,' ',2)
+ VOL1(:NCPHY)=0
+ VTURN(:NCPHY)=0
+ IAUX=IPOINT
+ IFVOL=1
+ MVOL=0
+ ICELC0=IFONC(NCOUR,0)
+ ICELC1=IFONC(NCOUR,1)-ICELC0
+ JVOL=1
+ IVOL=0
+ ISURB=NSMIN
+ JSURB=0
+ DO 100 I=1,NCEL
+ NVOL(I)=JVOL
+ IF(LG3D) THEN
+ DO 40 J=1,LZZ
+ NCC=J*LX
+ IF(I.LE.NCC) THEN
+ Z=ZZZ(J)
+ GO TO 42
+ ENDIF
+ 40 CONTINUE
+ ENDIF
+ 42 CONTINUE
+ MCYL=ICC(IBB(I))
+ IF(MCYL.GT.0) THEN
+*
+* STORAGE DES COORDONNEES DES CYLINDRES
+* ==> ATTENTION: LES AXES DES CYLINDRES SONT SELON Z
+*
+ DO 43 J=1,MCYL
+ IAUX=IAUX+1
+ REMESH(IAUX)=IOF(IBB(I))%R(J+1)
+ 43 CONTINUE
+ ENDIF
+ NCYL(I)=MCYL
+ NZONE1=1+MCYL
+ NZONE=0
+ DO 60 IA=1,NZONE1
+ NZONE=NZONE+IOF(IBB(I))%I2(IA)
+ 60 CONTINUE
+ NSECTO=IOF(IBB(I))%I2(NZONE1)
+ MCPHY=IBB(NCEL+I)
+ IV1=VOL1(MCPHY)
+ IF(IV1.GT.0) THEN
+ IF(LGTURN) THEN
+ JVT=PHTURN(MCPHY)
+ IVTURN=VTURN(MCPHY)
+ ITURN=IBB(2*NCEL+I)
+ KAUX=NSECTO-1
+ IF(ITURN.LE.6) THEN
+ IF(ITURN.NE.6)KAUX=KAUX*(ITURN+1)
+ ELSEIF(ITURN.GE.9) THEN
+ KAUX=(ITURN-8)*KAUX
+ ELSEIF(ITURN.EQ.7) THEN
+ KAUX=5*KAUX
+ ENDIF
+ ENDIF
+ ELSE
+ KVOL1=1
+ IF(MCPHY.GT.1)KVOL1=VOL1(MCPHY-1)
+ KVOL2=KVOL1+NZONE-1
+ IF(LGTURN) THEN
+ ITURN=IBB(2*NCEL+I)
+ PHTURN(MCPHY)=ITURN
+ IF(ITURN.LE.6) THEN
+ IF(ITURN.EQ.6) THEN
+ VTURN(MCPHY)=KVOL2+NSECTO-1
+ ELSE
+ VTURN(MCPHY)=KVOL2+(NSECTO-1)*(ITURN+1)
+ ENDIF
+ ELSEIF(ITURN.GE.8) THEN
+ VTURN(MCPHY)=KVOL2+(NSECTO-1)*(ITURN-8)+1
+ ELSE
+ VTURN(MCPHY)=KVOL2+(NSECTO-1)*5+1
+ ENDIF
+ ENDIF
+ VOL1(MCPHY)=KVOL2+1
+ ENDIF
+ VOLUM1=0.
+ IF(LG3D) THEN
+ IF(IPLANZ.GT.1) THEN
+ IF(I.LE.STAIRS(1)) THEN
+ FACB(I)=KSURF1
+ ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN
+ ISUR=ISUR+1
+ FACB(LX+ISUR)=KSURF2
+ ENDIF
+ ELSE
+ FACB(I)=KSURF1
+ FACB(LX+I)=KSURF2
+ ENDIF
+ Z=REMESH(2*NCEL+I)
+ IF(I.GT.STAIRS(1)) THEN
+ IST=1
+ DO 329 IY=2,LZZ
+ IF(I.LE.STAIRS(IY)) THEN
+ IST=IY-1
+ GOTO 339
+ ENDIF
+ 329 CONTINUE
+ 339 KZAUX=I-STAIRS(IST)
+ IF(IST.GT.1)KZAUX=KZAUX+STAIRS(IST-1)
+ Z=Z-REMESH(2*NCEL+KZAUX)
+ ENDIF
+ ENDIF
+ KSECTX=IOF(IBB(I))%I2(NZONE1)
+ NZZ=NZONE1
+ IF(KSECTX.GT.3)NZZ=NZONE1-1
+ DO 45 J=1,NZZ
+ MIXX=IOF(IBB(I))%I1(J)
+ KSECT=IOF(IBB(I))%I2(J)
+ NAUX=1
+ IF(KSECT.GT.1) NAUX=6*(KSECT-1)
+ IVOL=IVOL+NAUX
+ MVOL=MVOL+1
+ NSECT(MVOL)=KSECT
+ KREG=KREG+1
+ IF(J.EQ.NZONE1) THEN
+ VOLUM2=VEX
+ ELSE
+ R=IOF(IBB(I))%R(J+1)
+ VOLUM2=PI*R*R
+ ENDIF
+ VOLUMS=0.0
+ VOLUME=(VOLUM2-VOLUM1)/REAL(NAUX)
+ IF(LG3D) THEN
+ VOLUMS=VOLUME*.25
+ VOLUME=VOLUME*Z
+*
+* SURFACES SUPERIEURES ET INFERIEURES (SELON L'AXE Z)
+*
+ IF(IPLANZ.GT.1) THEN
+ IF(I.LE.STAIRS(1)) THEN
+ KSURF1=KSURF1+1
+ NSURF1=NSURF1-1
+ VOLSUR(NSURF1)=VOLUMS
+ ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN
+ KSURF2=KSURF2+1
+ NSURF2=NSURF2-1
+ VOLSUR(NSURF2)=VOLUMS
+ ENDIF
+ ELSE
+ KSURF1=KSURF1+1
+ NSURF1=NSURF1-1
+ VOLSUR(NSURF1)=VOLUMS
+ KSURF2=KSURF2+1
+ NSURF2=NSURF2-1
+ VOLSUR(NSURF2)=VOLUMS
+ ENDIF
+ ENDIF
+ VOLUM1=VOLUM2
+ VOLSUR(KREG)=VOLUME
+ MATALB(KREG)=MIXX
+ DO 44 K=2,NAUX
+ KREG=KREG+1
+ VOLSUR(KREG)=VOLUME
+ MATALB(KREG)=MIXX
+ IF(LG3D) THEN
+ IF(IPLANZ.GT.1) THEN
+ IF(I.LE.STAIRS(1)) THEN
+ KSURF1=KSURF1+1
+ NSURF1=NSURF1-1
+ VOLSUR(NSURF1)=VOLUMS
+ ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN
+ KSURF2=KSURF2+1
+ NSURF2=NSURF2-1
+ VOLSUR(NSURF2)=VOLUMS
+ ENDIF
+ ELSE
+ KSURF1=KSURF1+1
+ NSURF1=NSURF1-1
+ VOLSUR(NSURF1)=VOLUMS
+ KSURF2=KSURF2+1
+ NSURF2=NSURF2-1
+ VOLSUR(NSURF2)=VOLUMS
+ ENDIF
+ ENDIF
+ 44 CONTINUE
+ 45 CONTINUE
+ ICXX=LX*INT(AINT(REAL(I/(LX+1))))
+ ICELC=ICELC0+ICXX
+ ICLIM=LX+ICXX
+ IF(KSECTX.GT.3) THEN
+*
+* TRAITEMENT DU VOLUME A BORDURE HEXAGONALE DANS LE CAS OU KSECT>3
+*
+ KSECT=KSECTX
+ MIXX=IOF(IBB(I))%I1(NZONE1+1)
+ NAUX=6*(KSECT-1)
+ IVOL=IVOL+NAUX
+ MVOL=MVOL+1
+ NSECT(MVOL)=KSECT
+ VCYL=VOLUM1/REAL(NAUX)
+ SAUX=0.
+ IXX0=KREG
+ ISS0=NSURF1
+ JSS0=NSURF2
+ DO 445 M=1,KSECT-1
+ IXX=IXX0
+ ISS1=ISS0
+ ISS2=JSS0
+ XTAN=TAN(REAL(M)*PI/(3*(KSECT-1)))
+ SAUX1=XTAN/(1.+XTAN/SQRT3)
+ VOLUME=.5*SIDE*SIDE*(SAUX1-SAUX)
+ VOLUME=VOLUME-VCYL
+ VOLUMS=VOLUME
+ IF(LG3D) VOLUME=VOLUME*Z
+ DO 444 K=1,6
+ IXX=IXX+1
+ KREG=KREG+1
+ VOLSUR(IXX)=VOLUME
+ MATALB(IXX)=MIXX
+ IF(LG3D) THEN
+ IF(IPLANZ.GT.1) THEN
+ IF(I.LE.STAIRS(1)) THEN
+ KSURF1=KSURF1+1
+ NSURF1=NSURF1-1
+ ISS1=ISS1-1
+ VOLSUR(ISS1)=VOLUMS
+ ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN
+ KSURF2=KSURF2+1
+ NSURF2=NSURF2-1
+ ISS2=ISS2-1
+ VOLSUR(ISS2)=VOLUMS
+ ENDIF
+ ELSE
+ KSURF1=KSURF1+1
+ NSURF1=NSURF1-1
+ ISS1=ISS1-1
+ VOLSUR(ISS1)=VOLUMS
+ KSURF2=KSURF2+1
+ NSURF2=NSURF2-1
+ ISS2=ISS2-1
+ VOLSUR(ISS2)=VOLUMS
+ ENDIF
+ ISS1=ISS1-KSECT+2
+ ISS2=ISS2-KSECT+2
+ ENDIF
+ IXX=IXX+KSECT-2
+ 444 CONTINUE
+ IF(I.GE.ICELC.AND.I.LE.ICLIM) THEN
+ SURF=.5*SIDE*(SAUX1-SAUX)/SQRT3
+ IF(LG3D)SURF=SURF*Z
+ JSUR=JSUR-1
+ VOLSUR(JSUR)=SURF
+ IJSUR=JSUR-KSECT+1
+ VOLSUR(IJSUR)=SURF
+ IF(MOD(I-ICELC,ICELC1).EQ.0) THEN
+ IJSUR=IJSUR-KSECT+1
+ VOLSUR(IJSUR)=SURF
+ ENDIF
+ ENDIF
+ IXX0=IXX0+1
+ ISS0=ISS0-1
+ JSS0=JSS0-1
+ SAUX=SAUX1
+ 445 CONTINUE
+ IF(I.GE.ICELC.AND.I.LE.ICLIM) THEN
+ JSUR=JSUR-KSECT+1
+ JSURB=JSURB+2
+ SURB(JSURB-1)=ISURB
+ KKB=KSECT-1
+ ISURB=ISURB+KKB+KKB
+ SURB(JSURB)=ISURB-KKB
+ IF(MOD(I-ICELC,ICELC1).EQ.0) THEN
+ JSUR=JSUR-KSECT+1
+ JSURB=JSURB+1
+ SURB(JSURB)=ISURB
+ ISURB=ISURB+KKB
+ ENDIF
+ ENDIF
+ ELSE
+ IF(I.GE.ICELC.AND.I.LE.ICLIM) THEN
+ SURF=SIDE*.25
+ IF(LG3D)SURF=SURF*Z
+ KKB=1
+ IF(KSECT.GT.1) THEN
+ KKB=KSECT-1
+ SURF=SURF/KKB
+ ENDIF
+ DO 99 IXX=1,KKB
+ JSUR=JSUR-2
+ VOLSUR(JSUR)=SURF
+ VOLSUR(JSUR+1)=SURF
+ IF(MOD(I-ICELC,ICELC1).EQ.0) THEN
+ JSUR=JSUR-1
+ VOLSUR(JSUR)=SURF
+ ENDIF
+ 99 CONTINUE
+ JSURB=JSURB+2
+ SURB(JSURB-1)=ISURB
+ ISURB=ISURB+KKB+KKB
+ SURB(JSURB)=ISURB-KKB
+ IF(MOD(I-ICELC,ICELC1).EQ.0) THEN
+ JSURB=JSURB+1
+ SURB(JSURB)=ISURB
+ ISURB=ISURB+KKB
+ ENDIF
+ ENDIF
+ ENDIF
+ JVOL=IVOL+1
+ FVOL(I)=IFVOL
+ IFVOL=IFVOL+NZONE1
+ 100 CONTINUE
+ DO 110 I=1,ISTAT9
+ DEALLOCATE(IOF(I)%I1,IOF(I)%I2)
+ IF(ICC(I).GT.0) DEALLOCATE(IOF(I)%R)
+ 110 CONTINUE
+ DEALLOCATE(IOF,ICC)
+ ELSE
+*
+* CAS DE CELLULE HOMOGENES
+*
+ ALLOCATE(IBB(2*NCEL))
+ CALL LCMSIX(IPTRK,'DATA_DUP',1)
+ CALL LCMGET(IPTRK,'MERGE',IBB)
+ CALL LCMGET(IPTRK,'MIX',IBB(NCEL+1))
+ CALL LCMSIX(IPTRK,' ',2)
+ CALL LCMLEN(IPGEOM,'SECTOR',ILENS,ITP)
+ ALLOCATE(ICC(NCEL))
+ IF(ILENS.GT.0) THEN
+ CALL XABORT('MESHST: SECTORS NOT IMPLEMENTED.')
+ ELSE
+ ICC(:NCEL)=1
+ ENDIF
+ IF(LGTURN) THEN
+ CALL LCMSIX(IPTRK,'DATA_DUP',1)
+ ALLOCATE(ITT(NCEL))
+ CALL LCMGET(IPTRK,'TURN',ITT)
+ CALL LCMSIX(IPTRK,' ',2)
+ ENDIF
+ VOL1(:NCPHY)=0
+ IFVOL=1
+ MVOL=0
+ ICELC0=IFONC(NCOUR,0)
+ ICELC1=IFONC(NCOUR,1)-ICELC0
+ JVOL=1
+ IVOL=0
+ ISURB=NSMIN
+ JSURB=0
+ DO 200 I=1,NCEL
+ NVOL(I)=JVOL
+ NSECTO=ICC(I)
+ ICXX=LX*INT(AINT(REAL(I/(LX+1))))
+ ICELC=ICELC0+ICXX
+ ICLIM=LX+ICXX
+ NSECT(I)=NSECTO
+ NCYL(I)=0
+ NZONE=1
+ IF(NSECTO.GT.1)NZONE=6*(NSECTO-1)
+ IVOL=IVOL+NZONE
+ JVOL=IVOL+1
+ MCPHY=IBB(I)
+ IV1=VOL1(MCPHY)
+ IF(IV1.GT.0) THEN
+ IF(LGTURN) THEN
+ JVT=PHTURN(MCPHY)
+ IVTURN=VTURN(MCPHY)
+ KAUX=NSECTO-1
+ ITURN=ITT(I)
+ IF(ITURN.LE.6) THEN
+ IF(ITURN.NE.6)KAUX=KAUX*(ITURN+1)
+ ELSEIF(ITURN.GE.9) THEN
+ KAUX=(ITURN-8)*KAUX
+ ELSEIF(ITURN.EQ.7) THEN
+ KAUX=5*KAUX
+ ENDIF
+ ENDIF
+ ELSE
+ KVOL1=1
+ IF(MCPHY.GT.1)KVOL1=VOL1(MCPHY-1)
+ KVOL2=KVOL1+NZONE-1
+ IF(LGTURN) THEN
+ ITURN=ITT(I)
+ PHTURN(MCPHY)=ITURN
+ IF(ITURN.LE.6) THEN
+ IF(ITURN.EQ.6) THEN
+ VTURN(MCPHY)=KVOL2+NSECTO-1
+ ELSE
+ VTURN(MCPHY)=KVOL2+(NSECTO-1)*(ITURN+1)
+ ENDIF
+ ELSEIF(ITURN.GE.8) THEN
+ VTURN(MCPHY)=KVOL2+(NSECTO-1)*(ITURN-8)+1
+ ELSE
+ VTURN(MCPHY)=KVOL2+(NSECTO-1)*5+1
+ ENDIF
+ ENDIF
+ VOL1(MCPHY)=KVOL2+1
+ ENDIF
+ IF(NSECTO.LE.3) THEN
+ IF(I.GE.ICELC.AND.I.LE.ICLIM) THEN
+ SURF=SIDE*.25
+ IF(LG3D)SURF=SURF*Z
+ KKB=1
+ IF(NSECTO.GT.1) THEN
+ KKB=NSECTO-1
+ SURF=SURF/(NSECTO-1)
+ ENDIF
+ DO 556 IXX=1,KKB
+ JSUR=JSUR-2
+ VOLSUR(JSUR)=SURF
+ VOLSUR(JSUR+1)=SURF
+ IF(MOD(I-ICELC,ICELC1).EQ.0) THEN
+ JSUR=JSUR-1
+ VOLSUR(JSUR)=SURF
+ ENDIF
+ 556 CONTINUE
+ JSURB=JSURB+2
+ SURB(JSURB-1)=ISURB
+ ISURB=ISURB+KKB+KKB
+ SURB(JSURB)=ISURB-KKB
+ IF(MOD(I-ICELC,ICELC1).EQ.0) THEN
+ JSURB=JSURB+1
+ SURB(JSURB)=ISURB
+ ISURB=ISURB+KKB
+ ENDIF
+ ENDIF
+ VOLUMS=0.0
+ VOLUME=VEX/NZONE
+ IF(LG3D) THEN
+ Z=REMESH(2*NCEL+I)
+ IF(I.GT.STAIRS(1)) THEN
+ IST=1
+ DO 429 IY=2,LZZ
+ IF(I.LE.STAIRS(IY)) THEN
+ IST=IY-1
+ GOTO 439
+ ENDIF
+ 429 CONTINUE
+ 439 KZAUX=I-STAIRS(IST)
+ IF(IST.GT.1)KZAUX=KZAUX+STAIRS(IST-1)
+ Z=Z-REMESH(2*NCEL+KZAUX)
+ ENDIF
+ VOLUMS=VOLUME*.25
+ VOLUME=VOLUME*Z
+*
+* SURFACES SUPERIEURES ET INFERIEURES (SELON L'AXE Z)
+*
+ IF(IPLANZ.GT.1) THEN
+ IF(I.LE.STAIRS(1)) THEN
+ FACB(I)=KSURF1
+ KSURF1=KSURF1+1
+ NSURF1=NSURF1-1
+ VOLSUR(NSURF1)=VOLUMS
+ ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN
+ ISUR=ISUR+1
+ FACB(LX+ISUR)=KSURF2
+ KSURF2=KSURF2+1
+ NSURF2=NSURF2-1
+ VOLSUR(NSURF2)=VOLUMS
+ ENDIF
+ ELSE
+ FACB(I)=KSURF1
+ FACB(LX+I)=KSURF2
+ KSURF1=KSURF1+1
+ NSURF1=NSURF1-1
+ VOLSUR(NSURF1)=VOLUMS
+ KSURF2=KSURF2+1
+ NSURF2=NSURF2-1
+ VOLSUR(NSURF2)=VOLUMS
+ ENDIF
+ ENDIF
+ MIXX=IBB(NCEL+I)
+ DO 65 J=1,NZONE
+ KREG=KREG+1
+ VOLSUR(KREG)=VOLUME
+ MATALB(KREG)=MIXX
+ IF(LG3D) THEN
+ IF(IPLANZ.GT.1) THEN
+ IF(I.LE.STAIRS(1)) THEN
+ KSURF1=KSURF1+1
+ NSURF1=NSURF1-1
+ VOLSUR(NSURF1)=VOLUMS
+ ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN
+ KSURF2=KSURF2+1
+ NSURF2=NSURF2-1
+ VOLSUR(NSURF2)=VOLUMS
+ ENDIF
+ ELSE
+ KSURF1=KSURF1+1
+ NSURF1=NSURF1-1
+ VOLSUR(NSURF1)=VOLUMS
+ KSURF2=KSURF2+1
+ NSURF2=NSURF2-1
+ VOLSUR(NSURF2)=VOLUMS
+ ENDIF
+ ENDIF
+ 65 CONTINUE
+ ELSE
+*
+* TRAITEMENT DU CAS OU NSECTO>3
+*
+ KSECT=NSECTO
+ MIXX=IBB(NCEL+I)
+ NAUX=6*(KSECT-1)
+ IVOL=IVOL+NAUX
+ MVOL=MVOL+1
+ NSECT(MVOL)=KSECT
+ SAUX=0.
+ IXX0=KREG
+ ISS0=NSURF1
+ JSS0=NSURF2
+ DO 555 M=1,KSECT-1
+ IXX=IXX0
+ ISS1=ISS0
+ ISS2=JSS0
+ XTAN=TAN(REAL(M)*PI/(3*(KSECT-1)))
+ SAUX1=XTAN/(1.+XTAN/SQRT3)
+ VOLUME=.5*SIDE*SIDE*(SAUX1-SAUX)
+ VOLUMS=VOLUME
+ IF(LG3D) VOLUME=VOLUME*Z
+ DO 554 K=1,6
+ IXX=IXX+1
+ KREG=KREG+1
+ VOLSUR(IXX)=VOLUME
+ MATALB(IXX)=MIXX
+ IF(LG3D) THEN
+ IF(IPLANZ.GT.1) THEN
+ IF(I.LE.STAIRS(1)) THEN
+ KSURF1=KSURF1+1
+ NSURF1=NSURF1-1
+ ISS1=ISS1-1
+ VOLSUR(ISS1)=VOLUMS
+ ELSEIF(I.GT.STAIRS(IPLANZ-1)) THEN
+ KSURF2=KSURF2+1
+ NSURF2=NSURF2-1
+ ISS2=ISS2-1
+ VOLSUR(ISS2)=VOLUMS
+ ENDIF
+ ELSE
+ KSURF1=KSURF1+1
+ NSURF1=NSURF1-1
+ ISS1=ISS1-1
+ VOLSUR(ISS1)=VOLUMS
+ KSURF2=KSURF2+1
+ NSURF2=NSURF2-1
+ ISS2=ISS2-1
+ VOLSUR(ISS2)=VOLUMS
+ ENDIF
+ ISS1=ISS1-KSECT+2
+ ISS2=ISS2-KSECT+2
+ ENDIF
+ IXX=IXX+KSECT-2
+ 554 CONTINUE
+ IF(I.GE.ICELC.AND.I.LE.ICLIM) THEN
+ SURF=.5*SIDE*(SAUX1-SAUX)/SQRT3
+ IF(LG3D)SURF=SURF*Z
+ JSUR=JSUR-1
+ VOLSUR(JSUR)=SURF
+ IJSUR=JSUR-KSECT+1
+ VOLSUR(IJSUR)=SURF
+ IF(MOD(I-ICELC,ICELC1).EQ.0) THEN
+ IJSUR=IJSUR-KSECT+1
+ VOLSUR(IJSUR)=SURF
+ ENDIF
+ ENDIF
+ IXX0=IXX0+1
+ ISS0=ISS0-1
+ JSS0=JSS0-1
+ SAUX=SAUX1
+ 555 CONTINUE
+ IF(I.GE.ICELC.AND.I.LE.ICLIM) THEN
+ JSUR=JSUR-KSECT+1
+ JSURB=JSURB+2
+ SURB(JSURB-1)=ISURB
+ KKB=KSECT-1
+ ISURB=ISURB+KKB+KKB
+ SURB(JSURB)=ISURB-KKB
+ IF(MOD(I-ICELC,ICELC1).EQ.0) THEN
+ JSUR=JSUR-KSECT+1
+ JSURB=JSURB+1
+ SURB(JSURB)=ISURB
+ ISURB=ISURB+KKB
+ ENDIF
+ ENDIF
+ ENDIF
+ FVOL(I)=IFVOL
+ IFVOL=IFVOL+1
+ 200 CONTINUE
+ DEALLOCATE(ICC)
+ IF(LGTURN) DEALLOCATE(ITT)
+ ENDIF
+ IF(LG3D) DEALLOCATE(ZZZ)
+*
+*--- CONSTRUCTION DU VECTEUR VSYM QUI CONTIENT POUR CHAQUE VOLUME DE
+*--- DE L'ASSEMBLAGE SON EQUIVALENT DANS LA SYMETRIE D'ENTREE
+*
+ IF(LGCELL.AND.(IHEX.LE.9)) THEN
+ ALLOCATE(IAA(NCEL))
+ CALL LCMSIX(IPTRK,'DATA_DUP',1)
+ CALL LCMGET(IPTRK,'GENER0',IAA)
+ CALL LCMSIX(IPTRK,' ',2)
+ IXV=0
+ DO 300 IC=1,NCEL
+ MCYL=NCYL(IC)
+ LFROT=ROT(IBB(2*NCEL+IC))
+ IVFIN=KVOL(IAA(IC))
+ IVORIN=ITRN(IAA(IC))
+ IVMIN=IVFIN
+ IVSYM=NVOL(IC)
+ IXX=IXV
+ NZON=0
+ DO 310 I=1,MCYL
+ IXX=IXX+1
+ LSECT=NSECT(IXX)
+ IF(LSECT.GT.1) THEN
+ NZON=NZON+6*(LSECT-1)
+ ELSE
+ NZON=NZON+1
+ ENDIF
+ 310 CONTINUE
+ LSECT=NSECT(IXX+1)
+ IF(LSECT.GT.1) THEN
+ IVAUX=INT(REAL(IVORIN-IVFIN-NZON+1)/REAL(LSECT-1))
+ ELSE
+ IVAUX=IVORIN-IVFIN-NZON+1
+ ENDIF
+ DO 320 K=1,MCYL+1
+ IXV=IXV+1
+ LSECT=NSECT(IXV)
+ IF(LSECT.EQ.1) THEN
+ VSYM(IVSYM)=IVMIN
+ IVMAX=IVMIN
+ ELSE
+ IVOR=IVMIN+IVAUX*(LSECT-1)-1
+ IVV=LFROT-1
+ IVSYM0=IVSYM
+ IVSYM=IVSYM+6*(LSECT-1)-1
+ IVMAX=IVMIN+6*(LSECT-1)-1
+ IF(IBB(2*NCEL+IC).LE.6) THEN
+ IVV1=LFROT*(LSECT-1)
+ IVV=(5-IVV)*(LSECT-1)
+ ELSE
+ IVV1=IVV*(LSECT-1)+1
+ IVV=(6-IVV)*(LSECT-1)-1
+ ENDIF
+ IF(IBB(2*NCEL+IC).LE.6) THEN
+ KVV=IVSYM-IVV
+ KVOR=IVOR
+ DO 315 L=KVV,IVSYM
+ VSYM(L)=KVOR
+ KVOR=KVOR+1
+ IF(KVOR.GT.IVMAX)KVOR=IVMIN
+ 315 CONTINUE
+ DO 316 L=IVSYM0,KVV-1
+ VSYM(L)=KVOR
+ KVOR=KVOR+1
+ IF(KVOR.GT.IVMAX)KVOR=IVMIN
+ 316 CONTINUE
+ ELSE
+ KVV=IVSYM0+IVV1-1
+ KVOR=IVOR
+ DO 317 L=KVV,IVSYM0,-1
+ VSYM(L)=KVOR
+ KVOR=KVOR+1
+ IF(KVOR.GT.IVMAX)KVOR=IVMIN
+ 317 CONTINUE
+ DO 318 L=IVSYM,KVV+1,-1
+ VSYM(L)=KVOR
+ KVOR=KVOR+1
+ IF(KVOR.GT.IVMAX)KVOR=IVMIN
+ 318 CONTINUE
+ ENDIF
+ ENDIF
+ IVMIN=IVMAX+1
+ IVSYM=IVSYM+1
+ 320 CONTINUE
+ 300 CONTINUE
+ DEALLOCATE(IAA)
+*--- CONSTRUCTION DU VECTEUR SSYM QUI CONTIENT POUR CHAQUE SURFACE
+*--- DE L'ASSEMBLAGE SON EQUIVALENT DANS LA SYMETRIE D'ENTREE
+ ISY=0
+ MSAUX=NS
+ ISYX=NSMIN+1
+ IVLMAX=0
+ IF(LG3D) THEN
+ MSAUX=(NS-NSMIN-NSMAX)/IPLANZ
+*--- CAS DE LA SYMETRIE Z- (MCODE=1) SSYM EST REMPLIT PLUS LOIN
+ IF(MCODE.NE.1) THEN
+ IF(IHEX.NE.9) THEN
+ DO 301 ISUR=1,NSMIN
+ SSYM(ISUR)=VSYM(ISUR)
+ IVLMAX=MAX(IVLMAX,VSYM(ISUR))
+ 301 CONTINUE
+ ELSE
+ DO 311 ISUR=1,NSMIN
+ SSYM(ISUR)=ISUR
+ 311 CONTINUE
+ IVLMAX=NSMIN
+ ENDIF
+ ENDIF
+ ISY=NSMIN
+ ENDIF
+ IPPZ=IPP1
+ NSAUX=0
+ IF(MCODE.EQ.1) THEN
+ DO 302 IPPX=IPPZ+1,IPLANZ
+ NSAUX=NSAUX+(SURL(IPPX)-SURL(IPPX-1))
+ 302 CONTINUE
+ ISYX=ISYX+NSAUX
+ ENDIF
+ MSAUX=0
+ ISYAUX=ISYX
+ LSMAX=NSMIN+NSAUX
+ IF(MCODE.EQ.0) LSMAX=NS
+ LSPLZM=2*IPPZ-IPLANZ
+ DO 600 IP=1,IPPZ
+ IF(LG3D) THEN
+ IF(MCODE.EQ.1) THEN
+ LSMAX=LSMAX+(SURL(IPPZ-LSPLZM+IP)-SURL(IPPZ-LSPLZM-1+IP))
+ ISYAUX=ISYAUX+MSAUX
+ MSAUX=SURL(IPPZ-LSPLZM+IP)-SURL(IPPZ-LSPLZM-1+IP)
+ ELSE
+ LSMAX=NSMIN+SURL(IP)
+ ISYAUX=ISYX+MSAUX
+ MSAUX=SURL(IP)
+ ENDIF
+ ENDIF
+ ISY=ISYAUX-1
+ ISURSY=ISXY(1,IP)
+ ISURSX=ISXY(2,IP)
+ ISURB6=ISXY(3,IP)
+ IDEBX=ISXY(4,IP)
+ KSURBX=ISXY(5,IP)
+ ISAUX=ISXY(6,IP)
+ IDDX=ISURSX
+ KX2=ISURSY
+ KX1=ISURSY-ISURSX+1
+ KXP=1
+ IF(IHEX.GE.3) THEN
+ ISY=ISURB6+ISY
+ IF(IHEX.EQ.3.OR.IHEX.EQ.8) THEN
+ IDDX=0
+ KX2=KX1
+ KX1=ISURSY
+ KXP=-1
+ ENDIF
+ IF(IHEX.EQ.4.OR.IHEX.EQ.7)ISY=ISY-KSURBX
+ ENDIF
+ IDEB=ISAUX
+ IF(IHEX.EQ.2.OR.IHEX.EQ.7)IDEB=IDEBX
+ IF(IHEX.EQ.5.OR.IHEX.EQ.6) THEN
+ IDDX=-ISURSY
+ ISURSX=0
+ ISURSY=0
+ KX1=0
+ KX2=-1
+ ENDIF
+ DO 400 I=1,MROT
+ DO 349 K=KX1,KX2,KXP
+ ISY=ISY+1
+ IF(IHEX.GE.3) THEN
+ IF(ISY.GT.LSMAX) ISY=ISYAUX
+ ENDIF
+ SSYM(ISY)=K+IVLMAX
+ 349 CONTINUE
+ IF(IHEX.LT.9) THEN
+ DO 350 K=ISURSY-ISURSX,ISAUX,-1
+ ISY=ISY+1
+ IF(IHEX.GE.3) THEN
+ IF(ISY.GT.LSMAX) ISY=ISYAUX
+ ENDIF
+ SSYM(ISY)=K+IVLMAX
+ 350 CONTINUE
+ ENDIF
+ DO 351 K=IDEB,ISURSY-IDDX
+ ISY=ISY+1
+ IF(IHEX.GE.3) THEN
+ IF(ISY.GT.LSMAX) ISY=ISYAUX
+ ENDIF
+ SSYM(ISY)=K+IVLMAX
+ 351 CONTINUE
+ 400 CONTINUE
+ 600 CONTINUE
+*
+*---SURFACE LATERALES SUPERIEURES DANS LE CAS 3D
+*
+ IF(LG3D) THEN
+ IYAUX=0
+ IF(MCODE.LE.1) THEN
+ IF(IPLANZ.GT.1) THEN
+ IYAUX=IVLMAX
+ DO 599 II=NSMIN+1,NV-NSMAX
+ IYAUX=MAX(VSYM(II),IYAUX)
+ 599 CONTINUE
+ ENDIF
+ IF(IHEX.NE.9) THEN
+ IAUX=NV-NSMAX
+ DO 601 II=NS-NSMAX+1,NS
+ IAUX=IAUX+1
+ SSYM(II)=IVLMAX+MSMAX+VSYM(IAUX)-IYAUX
+ 601 CONTINUE
+ ELSE
+ IAUX=0
+ IF(MCODE.GT.0) THEN
+ KSAUX=SURL(IPLANI)
+ ELSE
+ KSAUX=SSYM(NS-NSMAX)
+ ENDIF
+ DO 611 II=NS-NSMAX+1,NS
+ IAUX=IAUX+1
+ SSYM(II)=IAUX+KSAUX
+ 611 CONTINUE
+ ENDIF
+ ENDIF
+*--- CAS DE SYMETRIE Z-
+ IF(MCODE.EQ.1) THEN
+ IF(IHEX.NE.9) THEN
+ DO 602 IV=1,NSMAX
+ SSYM(IV)=IVLMAX+MSMAX+VSYM(IV)-IYAUX
+ 602 CONTINUE
+ ELSE
+ IVLAT=1
+ IAUX=0
+ JTX=NS-NSMAX
+ DO 612 IX1=1,NCOUR
+ DO 613 JX=JTX+VLAT(NCOUR+IX1),JTX+IVLAT,-1
+ IAUX=IAUX+1
+ SSYM(IAUX)=SSYM(JX)
+ 613 CONTINUE
+ DO 614 JX=JTX+VLAT(IX1),JTX+VLAT(NCOUR+IX1)+1,-1
+ IAUX=IAUX+1
+ SSYM(IAUX)=SSYM(JX)
+ 614 CONTINUE
+ IVLAT=VLAT(IX1)+1
+ 612 CONTINUE
+ ENDIF
+ IFR=NSMIN
+ LSPLZM=2*IPLANI-IPLANZ
+ DO 605 IW=IPLANZ,IPPZ+1,-1
+ DO 603 JW=SURL(IPLANZ+IW),SURL(IW-1)+1,-1
+ IFR=IFR+1
+ SSYM(IFR)=SSYM(NSMIN+JW)
+ 603 CONTINUE
+ DO 604 JW=SURL(IW),SURL(IPLANZ+IW)+1,-1
+ IFR=IFR+1
+ SSYM(IFR)=SSYM(NSMIN+JW)
+ 604 CONTINUE
+ 605 CONTINUE
+ ELSEIF(MCODE.EQ.2) THEN
+ IFR=NS-NSMAX+1
+ MSUR=0
+ LSPLZP=2*IPLANI-IPLANZ
+ DO 705 IW=1,IPPZ-LSPLZP
+ DO 704 JW=SURL(IPLANZ+IW)+1,SURL(IW)
+ IFR=IFR-1
+ SSYM(IFR)=SSYM(NSMIN+JW)
+ 704 CONTINUE
+ DO 703 JW=MSUR+1,SURL(IPLANZ+IW)
+ IFR=IFR-1
+ SSYM(IFR)=SSYM(NSMIN+JW)
+ 703 CONTINUE
+ MSUR=SURL(IW)
+ 705 CONTINUE
+ IF(IHEX.NE.9) THEN
+ IAUX=NV-NSMIN
+ DO 706 II=NS-NSMAX+1,NS
+ IAUX=IAUX+1
+ SSYM(II)=VSYM(IAUX)
+ 706 CONTINUE
+ ELSE
+ IVLAT=1
+ IAUX=NS-NSMAX
+ DO 712 IX1=1,NCOUR
+ DO 713 JX=VLAT(NCOUR+IX1),IVLAT,-1
+ IAUX=IAUX+1
+ SSYM(IAUX)=SSYM(JX)
+ 713 CONTINUE
+ DO 714 JX=VLAT(IX1),VLAT(NCOUR+IX1)+1,-1
+ IAUX=IAUX+1
+ SSYM(IAUX)=SSYM(JX)
+ 714 CONTINUE
+ IVLAT=VLAT(IX1)+1
+ 712 CONTINUE
+ ENDIF
+ ENDIF
+ ENDIF
+ DEALLOCATE(IBB,KVOL,ITRN)
+ ELSE
+ DO 717 ISUR=1,NS
+ SSYM(ISUR)=ISUR
+ 717 CONTINUE
+ DO 718 IVOL=1,NV
+ VSYM(IVOL)=IVOL
+ 718 CONTINUE
+ ENDIF
+ DEALLOCATE(ISXY)
+*----
+* SCRATCH STORAGE DEALLOCATION
+*----
+ 800 DEALLOCATE(PHTURN,VTURN,VOL1)
+ RETURN
+ END
generated by cgit v1.2.3 (git 2.46.0) at 2026-02-16 13:16:01 +0000